PROGRAM TO INSTRUMENT (PLACE SAMPLE CALLS IN) A FORTRAN FILE

  ASKS FOR FILE NAME (A9, EXTENSION FOR ASSUMED)
    AND LOGICAL UNIT FOR SUMMARY (A8)

     CHARACTER*2160INLINE
     CHARACTER*8PUNAME
     CHARACTER*9TOKEN2
     CHARACTER*13FILE
     CHARACTER*8LU
     DIMENSION NPU(4)
     COMMON/INPBLK/ISTAT
     COMMON/TABBLK/NTABS,NBLINS,NINCLS
     COMMON/TABBKC/VTAB
     CHARACTER*1VTAB
  GET NAME AND UNIT
     CALL LIB$GET_INPUT(INLINE,'file name, unit (a9,a8): ',)
     I=INDEX(INLINE,',')
     FILE=INLINE(1:I-1)//'.for'
     LU=INLINE(I+1:I+8)
     OPEN(UNIT=1,FILE=FILE,STATUS='old',READONLY)

    INITIALIZE TABS

     NTABS=0
     VTAB=CHAR(9)
     NBLINS=0
     NINCLS=0

    PASS 1: COUNT PROGRAMS, FUNCTIONS, SUBROUTINES, AND ENTRIES

     DO 99999 I=1,4
     NPU(I)=0
9999 CONTINUE
     KSTATE=0
9998 IRET=INPUTL(INLINE,TOKEN2,2160,LENGTH)
  TEST END-OF-FILE
     IF(IRET.LT.1)GO TO 99997
  HANDLE COMMENT
     IF(IRET.EQ.1)GO TO 99998
  HANDLE PROGRAM, FUNCTION, SUBROUTINE, AND ENTRY
     IF(IRET.LE.5)THEN
     NPU(IRET-1)=NPU(IRET-1)+1
     CALL LIB$PUT_OUTPUT(INLINE(1:LENGTH))
     KSTATE=1
     GO TO 99998
     END IF
  HANDLE ASSUMED PROGRAM
     IF(KSTATE.EQ.0)THEN
     NPU(1)=NPU(1)+1
     CALL LIB$PUT_OUTPUT('      (program .main)')
     KSTATE=1
     END IF
     IF(IRET.EQ.6)KSTATE=0
     GO TO 99998

    PASS 2

9997 WRITE(INLINE,99996)NPU
9996 FORMAT(4I4)
     CALL LIB$PUT_OUTPUT(INLINE(1:16))
     NPU(1)=NPU(1)+NPU(2)+NPU(3)+NPU(4)

    LOOP TO RESCAN STATEMENTS, ADDING INSTRUMENTATION

     REWIND 1
     ISTAT=-1
     KSTATE=0
     OPEN(UNIT=2,FILE=FILE,STATUS='new')
     GO TO 99995
9994 CALL SPITIT(INLINE,LENGTH)
9995 IRET=INPUTL(INLINE,TOKEN2,2160,LENGTH)
    HANDLE END OF FILE
     IF(IRET.LT.1)GO TO 99993
    HANDLE COMMENT
     IF(IRET.EQ.1)GO TO 99994
    HANDLE PROGRAM, FUNCTION, SUBROUTINE
     IF(IRET.LE.4)THEN
     IRSAVE=IRET
     PUNAME=TOKEN2
     KSTATE=1
     GO TO 99994
     END IF
    HANDLE ASSUMED PROGRAM
     IF(KSTATE.EQ.0)THEN
     IRSAVE=2
     KSTATE=1
     PUNAME='.main   '
     END IF
    HANDLE ENTRY
     IF(IRET.EQ.5)THEN
     WRITE(2,99992)
     CALL SPITIT(INLINE,LENGTH)
     IRSAVE=5
     PUNAME=TOKEN2
     KSTATE=3
     WRITE(2,99991)PUNAME
     GO TO 99995
     END IF
9992 FORMAT('      call sampof')
9991 FORMAT('      call sampon(8h',A8,')')
    HANDLE END
     IF(IRET.EQ.6)THEN
     KSTATE=0
     GO TO 99994
     END IF
    PUT COMMON /SAMPBK/ BEFORE PROGRAM DECLARATIONS
     IF(KSTATE.EQ.1)THEN
     IF(IRSAVE.EQ.2)THEN
     NPU(2)=NPU(1)*5
     WRITE(2,99990)NPU(2)
     END IF
     KSTATE=2
     END IF
9990 FORMAT('      common /sampbk/ i1z9a0(',I4,')')
    HANDLE DECLARATION
     IF(IRET.EQ.7)GO TO 99994
    HANDLE ANYTHING ELSE
     IF(KSTATE.EQ.2)THEN
     IF(IRSAVE.EQ.2)THEN
     WRITE(TOKEN2,99996)NPU(1)
     WRITE(2,99989)TOKEN2(1:4)
     END IF
9989 FORMAT('      call sampin(',A4,')')
     KSTATE=3
     WRITE(2,99991)PUNAME
     END IF
    FOR RETURN, PROVIDE SAMPOF
     IF(IRET.EQ.8)THEN
     WRITE(2,99988)INLINE(1:6)
     INLINE(1:6)='      '
     END IF
9988 FORMAT(A6,'call sampof')
    FOR TERMINATE, PROVIDE SAMPDI
     IF(IRET.EQ.9)THEN
     WRITE(2,99987)INLINE(1:6),LU
     INLINE(1:6)='      '
     END IF
9987 FORMAT(A6,'call sampdi(',A8,')')
     GO TO 99994
9993 NTABS=NTABS/2
     NBLINS=NBLINS/2
     NINCLS=NINCLS/2
     IF(NTABS.GT.0)WRITE(6,'(1x,i7,'' tabs processed'')')NTABS
     IF(NBLINS.GT.0)WRITE(6,'(1x,i7,'' blank lines'')')NBLINS
     IF(NINCLS.GT.0)WRITE(6,'(1x,i7,'' include statements'')')NINCLS
     CALL EXIT
     END
     SUBROUTINE GETTOK(IR,IL,OR,IP)
     CHARACTER*(*)IR,OR

    RETURN NEXT TOKEN FROM INPUT FIELD

     OR=' '
9999 IF(IP.GT.IL)RETURN
     IF(IR(IP:IP).NE.' ')GO TO 99998
     IP=IP+1
     GO TO 99999
    IP POINTS TO FIRST NONBLANK CHARACTER
9998 MARK=ICHAR(IR(IP:IP))
     IF(MARK.GE.'141'O.AND.MARK.LE.'172'O)MARK=MARK-32
    SPECIAL CHARACTER TEST
     IF(MARK.LT.'101'O.OR.MARK.GT.'132'O)THEN
     OR=CHAR(MARK)
     IP=IP+1
     RETURN
     END IF
    IT IS A SYMBOL
     II=0
9997 II=II+1
     OR(II:II)=CHAR(MARK)
     IP=IP+1
     IF(IP.GT.IL)RETURN
     MARK=ICHAR(IR(IP:IP))
     IF(MARK.GE.'141'O.AND.MARK.LE.'172'O)MARK=MARK-32
     IF(MARK.LT.'060'O.OR.MARK.GT.'071'O.AND.MARK.LT.'101'O.OR.MARK.GT.
    +'132'O)RETURN
     GO TO 99997
     END
     SUBROUTINE INPUT1(LU,LBUF,IERROR)
  READ A RECORD, TESTING FOR EOF
    EXPAND TABS
     CHARACTER*72LBUF
     COMMON/TABBLK/NTABS,NBLINS,NINCLS
     COMMON/TABBKC/VTAB
     CHARACTER*1VTAB

     READ(LU,'(a72)',END=99999)LBUF
     IERROR=0
9998 I=INDEX(LBUF,VTAB)
     IF(I.LE.0)RETURN
     NTABS=NTABS+1
     J=(I+8).AND.'170'O
     K=72-J
     DO 99997 II=K,1,-1
     LBUF(J+II:J+II)=LBUF(I+II:I+II)
9997 CONTINUE
     J=MIN0(J,72)
     LBUF(I:J)=' '
     GO TO 99998
  END OF FILE
9999 IERROR=1
     RETURN
     END
     FUNCTION INPUTL(UBUF,TOKEN2,LIMIT,LENGTH)

    READ UBUF FROM UNIT 1

    RETURN

      -1  END OF FILE
       1  COMMENT/IMPLICIT/PARAMETER
       2  PROGRAM
       3  FUNCTION
       4  SUBROUTINE/BLOCK DATA
       5  ENTRY
       6  END
       7  DECLARATION (OR INCLUDE)
       8  RETURN
       9  STOP/CALL EXIT
      99  OTHER

    TOKEN2 IS SECOND TOKEN; E.G. SUBROUTINE NAME
    LENGTH IS LOCATION OF LAST NONBLANK CHARACTER

     COMMON/TABBLK/NTABS,NBLINS,NINCLS
     COMMON/TABBKC/VTAB
     CHARACTER*1VTAB
     CHARACTER*(*)UBUF
     CHARACTER*8TOKEN2
     CHARACTER*72LBUF
     CHARACTER*11TOKEN1
     COMMON/INPBLK/ISTAT
     DATA ISTAT/-1/
     DATA ISTACK/0/

     TOKEN2=' '
     LENGTH=0
     IF(ISTAT)99999,50,900
9999 CONTINUE
  MUST READ FIRST BUFFER FULL
     ISTAT=0
     CALL INPUT1(1,LBUF,IERROR)
     IF(IERROR.NE.0)GO TO 900
     GO TO 100

    LOOK FOR STACKED COMMAND

0    IF(ISTACK.EQ.0)GO TO 100
     LENGTH=72
     IF(ISTACK.EQ.1)THEN
     UBUF='      END IF'
     ISTACK=0
     GO TO 99997
     END IF
     IF(ISTACK.EQ.2)THEN
     UBUF='      RETURN'
     ISTACK=1
     GO TO 99997
     END IF
     IF(ISTACK.EQ.3)THEN
     UBUF='      STOP'
     ISTACK=1
     GO TO 99997
     END IF
     UBUF='      CALL EXIT'
     ISTACK=1
     GO TO 99997
  NORMAL ENTRY00   UBUF=LBUF
     LENGTH=72
    HANDLE COMMENT
     IF(UBUF(1:1).EQ.'c'.OR.UBUF(1:1).EQ.'C'.OR.UBUF(1:1).EQ.'*')GO TO 
    +99998
     IF(UBUF.NE.' ')GO TO 99996
     NBLINS=NBLINS+1
9998 INPUTL=1
     CALL INPUT1(1,LBUF,IERROR)
     IF(IERROR.NE.0)GO TO 99994
     GO TO 800
9994 ISTAT=1
     GO TO 800
9996 CONTINUE
  HANDLE CONTINUATIONS
9995 CONTINUE
     CALL INPUT1(1,LBUF,IERROR)
     IF(IERROR.NE.0)GO TO 99992
     GO TO 99993
9992 ISTAT=1
9993 CONTINUE
     IF(ISTAT.NE.0)GO TO 99997
     IF(LBUF(1:5).NE.' ')GO TO 99997
     IF(LBUF(6:6).EQ.' '.OR.LBUF(6:6).EQ.'0')GO TO 99997
     IF(LENGTH+66.GT.LIMIT)THEN
     CALL LIB$PUT_OUTPUT('fatal error - line too long')
     STOP
     END IF
     UBUF=UBUF(1:LENGTH)//LBUF(7:72)
     LENGTH=LENGTH+66
     GO TO 99995

    LOOK UP STATEMENT TYPE

9997 J=7
     CALL GETTOK(UBUF,LENGTH,TOKEN1,J)
     CALL GETTOK(UBUF,LENGTH,TOKEN2,J)
    END TEST
     IF(TOKEN1.EQ.'END'.AND.TOKEN2.EQ.' ')THEN
     INPUTL=6
     GO TO 800
     END IF
    TRY PROGRAM, FUNCTION, SUBROUTINE, OR ENTRY STATEMENT
     M=ICHAR(TOKEN2(1:1))
     IF(M.LT.'101'O.OR.M.GT.'132'O)GO TO 99991
     IF(TOKEN1.EQ.'PROGRAM')THEN
     INPUTL=2
     GO TO 800
     END IF
     IF(TOKEN1.EQ.'FUNCTION')THEN
     INPUTL=3
     GO TO 800
     END IF
     IF(TOKEN1.EQ.'SUBROUTINE'.OR.TOKEN1.EQ.'BLOCK'.AND.TOKEN2.EQ.
    +'DATA')THEN
     INPUTL=4
     GO TO 800
     END IF
     IF(TOKEN1.EQ.'ENTRY')THEN
     INPUTL=5
     GO TO 800
     END IF

    LOOK FOR TYPE 1 OR 7 STATEMENT

9991 INPUTL=7
     M=ICHAR(TOKEN2(1:1))
  TRY INCLUDE
     IF(TOKEN1.EQ.'INCLUDE'.AND.M.EQ.'047'O)THEN
     NINCLS=NINCLS+1
     GO TO 800
     END IF
  TRY IMPLICIT OR PARAMETER
     IF(TOKEN1.EQ.'PARAMETER'.AND.M.EQ.'050'O)THEN
     INPUTL=1
     GO TO 800
     END IF
     IF(TOKEN1.EQ.'IMPLICIT')THEN
     IF(M.LT.'101'O.OR.M.GT.'132'O)GO TO 99990
     INPUTL=1
     GO TO 800
     END IF
  DIMENSION, COMMON, EQUIVALENCE
     IF(TOKEN1.EQ.'DIMENSION')THEN
     IF(M.GE.'101'O.AND.M.LE.'132'O)GO TO 800
     GO TO 99990
     END IF
     IF(TOKEN1.EQ.'COMMON')THEN
     IF(M.GE.'101'O.AND.M.LE.'132'O.OR.M.EQ.'057'O)GO TO 800
     GO TO 99990
     END IF
     IF(TOKEN1.EQ.'EQUIVALENCE')THEN
     IF(M.EQ.'050'O)GO TO 800
     GO TO 99990
     END IF
  DATA
     IF(TOKEN1.EQ.'DATA')THEN
     IF(M.GE.'101'O.AND.M.LE.'132'O.OR.M.EQ.'050'O)GO TO 800
     END IF

    TRY FOR TYPE OR TYPED FUNCTION STATEMENT

     IF((M.LT.'101'O.OR.M.GT.'132'O).AND.M.NE.'052'O)GO TO 99990
     IF(TOKEN1.EQ.'DOUBLE'.AND.TOKEN2.EQ.'PRECISION')THEN
     CALL GETTOK(UBUF,LENGTH,TOKEN2,J)
     M=ICHAR(TOKEN2(1:1))
     IF(M.EQ.'040'O)GO TO 800
     ELSE
     IF(TOKEN1.NE.'INTEGER'.AND.TOKEN1.NE.'REAL'.AND.TOKEN1.NE.
    +'LOGICAL'.AND.TOKEN1.NE.'CHARACTER'.AND.TOKEN1.NE.'COMPLEX')GO TO 
    +99990
     END IF
9989 CONTINUE
     IF(M.LT.'101'O.OR.M.GT.'132'O)THEN
     CALL GETTOK(UBUF,LENGTH,TOKEN2,J)
     M=ICHAR(TOKEN2(1:1))
     IF(M.EQ.'040'O)GO TO 800
     GO TO 99989
     END IF
     IF(TOKEN2.NE.'FUNCTION')GO TO 800
     CALL GETTOK(UBUF,LENGTH,TOKEN2,J)
     M=ICHAR(TOKEN2(1:1))
     IF(M.GE.'101'O.AND.M.LE.'132'O)INPUTL=3
     GO TO 800

    TRY FOR RETURN, STOP, OR CALL EXIT STATEMENT

9990 CONTINUE
     IF(TOKEN2.EQ.' ')THEN
     IF(TOKEN1.EQ.'RETURN')THEN
     INPUTL=8
     GO TO 800
     END IF
     IF(TOKEN1.EQ.'STOP')THEN
     INPUTL=9
     GO TO 800
     END IF
     END IF
     IF(TOKEN1.EQ.'CALL'.AND.TOKEN2.EQ.'EXIT')THEN
     INPUTL=9
     GO TO 800
     END IF
  NOT RECOGNIZED
     INPUTL=99

    TEST FOR CONTROL IN LOGICAL IF

     IF(TOKEN1.NE.'IF'.OR.TOKEN2.NE.'(')GO TO 800
     I=6
9988 CONTINUE
     K=INDEX(UBUF(I+1:LENGTH),')')
     I=I+K
     IF(K.NE.0)GO TO 99988
     J=I+1
     CALL GETTOK(UBUF,LENGTH,TOKEN1,J)
     CALL GETTOK(UBUF,LENGTH,TOKEN2,J)
     IF(TOKEN2.EQ.' ')THEN
     IF(TOKEN1.EQ.'RETURN')THEN
     ISTACK=2
     ELSE
     IF(TOKEN1.EQ.'STOP')THEN
     ISTACK=3
     ELSE
     GO TO 800
     END IF
     END IF
     ELSE
     IF(TOKEN2.NE.'EXIT')GO TO 800
     IF(TOKEN1.NE.'CALL')GO TO 800
     ISTACK=4
     END IF
     UBUF(I+1:LENGTH)='THEN'

   HERE TO TRIM

00   IF(UBUF(LENGTH:LENGTH).NE.' ')RETURN
     IF(LENGTH.EQ.1)RETURN
     LENGTH=LENGTH-1
     GO TO 800

    HERE TO RETURN END OF FILE

00   INPUTL=-1
     RETURN
     END
     SUBROUTINE SPITIT(INLINE,LENGTH)

    WRITE "INLINE" AS A FORTRAN STATEMENT

     CHARACTER*(*)INLINE

     K=MIN0(LENGTH,72)
     WRITE(2,99999)(INLINE(I:I),I=1,K)
9999 FORMAT(72A1)
9998 CONTINUE
     IF(K.LT.LENGTH)THEN
     J=K+1
     K=MIN0(K+66,LENGTH)
     WRITE(2,99997)(INLINE(I:I),I=J,K)
     GO TO 99998
     END IF
9997 FORMAT('     &',66A1)
     RETURN
     END