C         ***********************************************************
C         *                                                         *
C         *  SNAP:  PRODUCES 6 WORD/LINE OCTAL AND FIELDATA DUMPS.  *
C         *       CALLING SEQUENCE:                                 *
C         *                                                         *
C         *       CALL  SNAP  (ORG,LNG,'ID'), WHERE:                *
C         *                                                         *
C         *  ORG IS AN EXPRESSION WHOSE VALUE IS THE FIRST ADDRESS  *
C         *  TO DUMP, LNG IS IN WORDS, AND ID IS VAR LNG ID STRING. *
C         *  ID MUST CONFORM TO FORMAT FOR HOLLERITH LITERALS.      *
C         *                             A GREG BAILEY PRODUCT.      *
C         ***********************************************************
C
      SUBROUTINE  SNAP (ORG,LNG,ID)
      COMPILER (GEN=NOTRA)
C
      IMPLICIT  INTEGER (A-Z)
      DIMENSION  ID(1), CORE(1), BUF(6)
      COMMON  /N0RGSZ/ N0RGSA(44)
C
      DO 10 I=1,150
   10     IF (FLD(0,6,ID(I)).EQ.2**6-1) GO TO 12
      I = 150
   12 I = I-1
      WRITE (6,100) (ID(J),J=1,I)
      IF (LNG.EQ.0) RETURN
      LOCEND = ORG+IABS(LNG)-1 - MOD(IABS(LNG)-1,6) @ FIRST OF LAST 6.
      OFFSET = LOC(CORE) - 1                 @ ABSOLUTE ADDRESSING.
      IDENT = 0
C
      DO 50 LINADR=ORG,LOCEND,6
      NIDFLG = 0
          DO 20 I=1,6
   20         BUF(I) = ' '
      LINEND = MIN(LINADR+5,ORG+ABS(LNG)-1)
          DO 40 ADDR=LINADR,LINEND
              WORD = CORE(ADDR-OFFSET)
      IF (WORD.NE.CORE(ADDR-OFFSET-6).OR.LINADR.EQ.ORG) NIDFLG = 1
      DO 30 I=1,6
              FLD(30,6,BUF(ADDR-LINADR+1)) = FLD(0,6,WORD)
              IF (FLD(0,6,WORD).EQ.2**6-1)
     1           FLD(30,6,BUF(ADDR-LINADR+1)) = '@@@@@.'
              IF (I.EQ.6) GO TO 40
              WORD = WORD*64
   30         BUF(ADDR-LINADR+1) = BUF(ADDR-LINADR+1) * 64
   40 CONTINUE
      IF (NIDFLG.NE.0) GO TO 45
          IDENT = IDENT+1
          GO TO 50
   45 IF (IDENT.EQ.0) GO TO 47
          WRITE (6,210) IDENT
          IDENT = 0
   47     CONTINUE
          IS = 6
          WRITE (6,200) LINADR, (BUF(II), II=1,IS),
     *     (CORE (I-OFFSET), I=LINADR,LINEND)
   50 CONTINUE
      IF (IDENT.NE.0) WRITE (6,210)IDENT
      RETURN
C
  100 FORMAT ('0SNAP ID:',2X,20A6 / (11X,20A6))
  200 FORMAT (1X,O6,87X,'*',6A6,'*',T11,6(O12,2X))
  210 FORMAT (7X,'***',I5,' IDENTICAL LINES.')
      END
