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$