FTN4,L,Q,T
      PROGRAM SNPSH ,,89
      IMPLICIT INTEGER (A-Z)
      DIMENSION IDCB1(144), IDCB2(144), IBUF(128), JBUF(30), PBUF(10) 
      DIMENSION MES1(8), MES4(13) 
      DATA MES1/2HSN,2HAP,2HSH,2HOT,2H W,2HRI,2HTT,2HEN/
      DATA MES4/2HER,2HRO,2HR ,2HIN,2H F,2HIL,2HE ,2HWR,2HIT,2HE:,
     &2H R,2HET,2HRY/ 
C     DEFINE SYSTEM LOCATIONS 
      DATA DSCLB/1761B/, DSCLN/1762B/, SYSLN/1764B/, SECT2/1757B/ 
C 
C-------------------------------------------------------------------- 
C 
C          RU,SNPSH,DEST1,DEST2 
C 
C          SNPSH PUTS A SNAPSHOT OF ALL ENTRY POINTS INTO DEST1,
C          AND AN IMAGE OF THE 32K OF THE SYSTEM MAP INTO DEST2.
C 
C          THE ENTRY POINTS ARE FOUND AT DSCLB IN THE SYSTEM
C          COMMUNICATIONS AREA. THERE ARE DSCLN+SYSLN 4 WORD ENTRIES. 
C 
C          THE IMAGE OF THE SYSTEM IS TAKEN FROM TWO PLACES:
C          THE FIRST PAGE IS TAKEN FROM THE DISK, STARTING AT SECTOR
C          $SSCT.  THE NEXT 31K OF THE SYSTEM IS COPIED FROM THE SYSTEM 
C          MAP WITH IXGET.  THE FINAL PORTION (THE DRIVER PARTITIONS) 
C          ARE TAKEN FROM THE DISK.  THE NUMBER OF PAGES IS DETERMINED BY 
C          THE CONTENTS OF $MRMP ($MRMP CONTAINS THE PAGE NUMBER OF THE 
C          FIRST PAGE AFTER THE END OF THE DRIVER PARTITIONS. 
C 
C          SECT2 CONTAINS THE NUMBER OF SECTORS/TRACK ON LU 2.
C 
C          DEST1 AND DEST2 MAY BE LU'S OR FILES.
C 
C          LAST MODIFIED 12/05/79 BY JEF
C 
C-------------------------------------------------------------------- 
C 
      ILU = LOGLU(IDUM) 
C 
C         CALCULATE LOCATION OF ENTRY POINTS
C 
      ISCNT = IXGET(SECT2)
      ITRK = IXGET(DSCLB)/128 
      ISECT = IAND(IXGET(DSCLB),177B) 
      ICNT = IXGET(DSCLN)+IXGET(SYSLN)
C 
C          GET PARAMETERS 
C 
      CALL EXEC(14,1,JBUF,-60)
      CALL ABREG(A,B) 
C 
C         WIPE OUT "RU,SNPSH,"
C 
      ICHAR = 1 
      CALL NAMR(PBUF,JBUF,B,ICHAR)
      CALL NAMR(PBUF,JBUF,B,ICHAR)
C 
C         PARSE PARMS, CREATE AND OPEN FILES
C 
      CALL CSUB(JBUF,ICHAR,B,IDCB1,IERR,(ICNT+31)/32,ILU) 
C 
C****      DUMP ENTRY POINTS
C 
      SSCT = 0
      MRMP = 0
      DO 100 I = 1,(ICNT+31)/32 
C 
C         READ A 64 WORD SECTOR OF ENTRY POINTS 
C 
          CALL EXEC(1,102B,IBUF,64,ITRK,ISECT)
          ISECT = ISECT + 1 
          IF (ISECT.NE.ISCNT) GO TO 80
              ISECT = 0 
              ITRK = ITRK + 1 
C 
C         READ ANOTHER 64 WORD SECTOR OF ENTRY POINTS 
C 
 80       CALL EXEC(1,102B,IBUF(65),64,ITRK,ISECT)
          ISECT = ISECT + 1 
          IF (ISECT.NE.ISCNT) GO TO 90
              ISECT = 0 
              ITRK = ITRK + 1 
C 
C         IF THIS IS THE END OF THE AREA, ZERO OUT THE
C         REST OF THE BUFFER
C 
 90       IF (ICNT.GT.31) GO TO 97
              DO 95 J = (ICNT*4+1),128
                  IBUF(J) = 0 
 95           CONTINUE
C 
C         WRITE A 128 WORD OUTPUT RECORD
C 
 97       CALL WRITF(IDCB1,IERR,IBUF,128) 
          ICNT = ICNT - 32
          IF(IERR.GE.0) GO TO 98
              CALL EXEC(2,ILU,MES4,13)
              CALL CCLOS(IDCB1) 
              STOP
C 
C         CHECK THE BUFFER FOR $SSCT (SECTOR ADDR OF BOOT IMAGE)
C 
 98       DO 99 J = 1,128,4 
              IF(IBUF(J).EQ.2H$S.AND. 
     &          IBUF(J+1).EQ.2HSC.AND.
     &          IAND(IBUF(J+2),177400B).EQ.IAND(2HT ,177400B))
     &            SSCT = IBUF(J+3)
 99       CONTINUE
C 
C         CHECK THE BUFFER FOR $MRMP (ADDR OF MR MAP) 
C 
          DO 96 J = 1,128,4 
              IF(IBUF(J).EQ.2H$M.AND. 
     &          IBUF(J+1).EQ.2HRM.AND.
     &          IAND(IBUF(J+2),177400B).EQ.IAND(2HP ,177400B))
     &            MRMP = IBUF(J+3)
 96       CONTINUE
 100  CONTINUE
C 
C          CLOSE 1ST FILE 
C 
      CALL CCLOS(IDCB1) 
C 
C****     DUMP THE SYSTEM IMAGE 
C 
C         CHECK THE VALUE OF $MRMP AND C(C($MRMP)); THEN
C         OPEN THE SECOND FILE
C 
      SSCT = IXGET(SSCT)
      IF(MRMP.NE.0) GO TO 110 
          CALL EXEC(2,ILU,38H$MRMP UNDEFINED; NO DRIVER PARTITIONS ,-38)
 110  MRMP = IXGET(IXGET(MRMP)) 
      IF(MRMP.LT.32) MRMP = 32
      IF(MRMP.GT.64) MRMP = 48
C 
      CALL CSUB(JBUF,ICHAR,B,IDCB2,IERR,8*MRMP,ILU) 
C 
C         DUMP THE FIRST PAGE FROM THE BOOT IMAGE ON THE DISK 
C 
      CALL DMP(SSCT, ISCNT, 8, IBUF, IDCB2, ILU)
C 
C         NOW DUMP PAGES 2-32 OF THE SYSTEM MAP 
C 
      ICNT = 0
      DO 200 J = 1024,32767 
C 
C         GET A WORD FROM THE SYSTEM MAP
C 
          ICNT = ICNT + 1 
          IBUF(ICNT) = IXGET(J) 
C 
C         IF WE HAVE ACCUMULATED 128 WORDS, OUTPUT IT 
C 
          IF(ICNT.LT.128) GO TO 200 
              ICNT = 0
              CALL WRITF(IDCB2,IERR,IBUF,128) 
              IF(IERR.GE.0) GO TO 200 
                  CALL EXEC(2,ILU,MES4,13)
                  CALL CCLOS(IDCB2) 
                  STOP
 200  CONTINUE
C 
C         NOW DUMP THE DRIVER PARTITIONS
C 
      CALL DMP(SSCT+512, ISCNT, (MRMP-32)*8, IBUF, IDCB2, ILU)
C 
C          CLOSE FILE AND WRITE TERMINATION MESSAGE 
C 
 300  CALL CCLOS(IDCB2) 
      CALL EXEC(2,ILU,MES1,8) 
C 
      END 
      SUBROUTINE CSUB(IBUF,ICHAR,LEN,IDCB,IERR,ISIZE,ILU) 
      IMPLICIT INTEGER (A-Z)
      DIMENSION IDCB(144), IBUF(128), PBUF(10)
      DIMENSION MES2(19),MES3(18),MES5(7) 
      DATA MES2/2HSP,2HEC,2HIF,2HY ,2HOU,2HTP,2HUT,2H F,2HIL,2HES,
     &2H/L,2HUS,2H (,2H2 ,2HRE,2HQU,2HIR,2HED,2H) / 
      DATA MES3/2HFI,2HLE,2H C,2HAN,2HNO,2HT ,2HBE,2H C,2HRE,2HAT,
     &2HED/ 
      DATA MES5/2HCA,2HNN,2HOT,2H O,2HPE,2HN ,2HLU/ 
C 
C         SUBROUTINE TO PARSE A NAMR/LU AND 
C             A) NAMR - CREATE AND OPEN THE FILE
C             B) LU   - LOCK AND OPEN THE LU
C-----------------------------------------------------------------
C 
C         PARSE THE NAMR
C 
      HOLD = NAMR(PBUF,IBUF,LEN,ICHAR)
      PBUF(4) = IAND(PBUF(4),3B)
      IF(HOLD.GE.0.AND.(PBUF(4).EQ.1.OR.PBUF(4).EQ.3)) GO TO 10 
          CALL EXEC(2,ILU,MES2,19)
          STOP
C 
C         CREATE AND OPEN IF A FILE; IF IT ALREADY EXISTS, AN ERROR 
C         MESSAGE IS PRINTED AND THE PROGRAM EXITS. 
C 
 10   IF(PBUF(4).EQ.1) GO TO 20 
          CALL CREAT(IDCB,IERR,PBUF,ISIZE,1,PBUF(5),PBUF(6))
          IF(IERR.GE.0) RETURN
              CALL EXEC(2,ILU,MES3,11)
              STOP
C 
C         AN LU WAS SPECIFIED; LOCK AND OPEN IT 
C 
C     ELSE
 20       CALL LURQ(1,PBUF(1),1)
          CALL OPENF(IDCB,IERR,PBUF,110B) 
          IF(IERR.GE.0) RETURN
              CALL EXEC(2,ILU,MES5,7) 
              STOP
      END 
      SUBROUTINE CCLOS(IDCB)
      IMPLICIT INTEGER (A-Z)
      DIMENSION IDCB(144) 
C 
C         SUBROUTINE TOWWRITE AN END-OF-FILE, REWIND THE FILE,
C         CLOSE IT, AND RELEASE ALL LU'S
C 
      CALL WRITF(IDCB,IERR,IBUF,-1) 
      CALL RWNDF(IDCB,IERR) 
      CALL CLOSE(IDCB)
      CALL LURQ(100000B,IDMY,IDMY)
      RETURN
      END 
      SUBROUTINE DMP(SCT,ISCNT,LEN,IBUF,IDCB2,ILU)
      IMPLICIT INTEGER (A-Z)
      DIMENSION IBUF(128),IDCB2(144)
C 
C     DMP DUMPS BLOCKS FROM THE BOOT IMAGE TO THE SNAP FILE 
C 
C     SECT     SECTOR ADDRESS ON THE DISK 
C     ISCNT    NUMBER OF SECTORS/TRACK
C     LEN      NUMBER OF BLOCKS TO COPY 
C     IBUF     BUFFER (128 WORDS) 
C     IDCB2    DCB FOR THE OUTPUT FILE
C     ILU      LU OF THE TERMINAL 
C 
C---------------------------------------------------------------------------
C 
      SECT = SCT
      TRK = SECT/ISCNT
      SECT = SECT - TRK*ISCNT 
      IF(LEN.LE.0) RETURN 
      DO 150 J = 1,LEN
C 
C         GET A 64 WORD SECTOR
C 
          CALL EXEC(1,102B,IBUF,64,TRK,SECT)
          SECT = SECT+1 
          IF(SECT.LT.ISCNT) GO TO 130 
              TRK = TRK+1 
              SECT = 0
C 
C         GET ANOTHER 64 WORD SECTOR
C 
 130      CALL EXEC(1,102B,IBUF(65),64,TRK,SECT)
          SECT = SECT+1 
          IF(SECT.LT.ISCNT) GO TO 140 
              TRK = TRK+1 
              SECT = 0
C 
C         WRITE 128 WORDS TO THE OUTPUT 
C 
 140      CALL WRITF(IDCB2,IERR,IBUF,128) 
          IF(IERR.GE.0) GO TO 150 
              CALL EXEC(2,ILU,26HERROR IN FILE WRITE: RETRY,13) 
              STOP
 150  CONTINUE
      RETURN
      END 
      END$
                                                                                                                    