INCLUDE/NL [314,6]DEFINS
DEFINE(LUNIN=1)
DEFINE(LUNOUT=2)
DEFINE(USERIN=5)
DEFINE(USEROUT=5)
DEFINE(PAGELENGTH,56)
DEFINE (OTHERWISE,ELSE)

#$ COMPRS - SUBROUTINE TO GET RID OF SUBROUTINE TYPE INFO
#
   SUBROUTINE COMPRS (BUFR)
#
   CHARACTER BUFR(133)
   INTEGER SLEN, LEN, SCOPY, JUNK, ICOL
#
   LEN=SLEN(BUFR)
   FOR (ICOL=15; ICOL <= LEN; ICOL=ICOL+8) [
      JUNK=SCOPY (BUFR(ICOL), BUFR(ICOL-6), 132, JUNK)
      LEN=LEN-6
      ]
   BUFR(ICOL-7)=EOS
   RETURN
   END
#
#$ MAPPS - MAINLINE TO LIST PROGRAM SYSTEM SUMMARY
#
   INTEGER  SWITCH(4,11), ICSI, DOIT, I, J, STATUS, SLEN, JUNK
   INTEGER STRPUT, SITOC
   INTEGER PLINE, PAGE
   CHARACTER NAMES(35,9)
   REAL DEFALT(4)
   COMMON / MAPPS / PLINE, PAGE
#
INCLUDE [314,6]CICSI
#
   STRING PROMPT "MAP>"				#PCN #77
   DATA DEFALT /"MAP ", "    ", "    ", "XXX "/	#DEFAULT EXTENSIONS, PCN#71
   DATA IFIRST/ YES /					#FOR ICSI 
#
#
   CALL ERRSET (63,.TRUE.,.FALSE.,,.FALSE.)	#TURN OFF CONVERSION ERRORS
   CALL ERRSET (43,.TRUE.,.FALSE.,,.FALSE.)	#TURN OFF BAD FILE NAME ERRORS LOGGING
   CALL ERRSET (29,.TRUE.,.FALSE.,,.FALSE.)	#TURN OFF NO SUCH FILE ERRORS
   CALL ERRSET (39,.TRUE.,.FALSE.,,.FALSE.)	#TURN OFF READ ERRORS
   CALL ERRSET (30,.TRUE.,.FALSE.,,.FALSE.)	#TURN OFF OPEN FAILURE ERRORS
#
#
   PLINE=9999
   PAGE=0
   USER=USERIN
   INDLUN=0		#FOR ICSI
REPEAT [
   CLB(1)=EOS
   STATUS=ICSI(NAMES,DEFALT,SWITCH,11,PROMPT)
   IF (STATUS == EOF)
      CALL EXIT				#DONE!
   ELSE IF (STATUS == YES) [			#DO A GOOD LINE
            CALL ERRSNS
            CALL ASSIGN(LUNOUT,NAMES(1,1),0)	#FORTRAN OUTPUT FILE
            CALL FDBSET (LUNOUT, "NEW",,2)	#RSX!!!
            CALL ERRSNS (I)			#CHECK FOR VALID FILE NAME STRINGS
            CALL QIO (768,LUNOUT)			#ATTACH TERMINAL
            IF (I != 0) [
               CALL ICSIE ("Bad Output File spec!")
               NEXT
               ]
            ELSE IF (STRPUT(LUNOUT, " ", BLANK) != YES) [
               CALL ICSIE ("Open Failure on Output")
               NEXT
               ]
            ELSE
               REWIND LUNOUT
#
         FOR (J=4; J <= 9 & SLEN(NAMES(1,J)) > 0; INCREMENT(J)) [
            CALL ERRSNS
            CALL ASSIGN (LUNIN,NAMES(1,J),0)			#BASIC INPUT FILE
            CALL FDBSET (LUNIN, "READONLY", "SHARE")		#RSX!!!
            CALL ERRSNS (I)				#CHECK FOR FILENAME SPEC ERRORS
            IF (I != 0) [
               CALL ICSIE ("Bad Input File Spec!")
               BREAK
               ]
            CALL REPORT 				#DO ALL THE WORK HERE
            CALL CLOSE (LUNIN)
#
            ]
         CALL CLOSE (LUNOUT)
         ]
   ]		#GET ANOTHER COMMAND LINE
#
   END
#
#$ OUTPUT - TO LIST PROGRAM MAPPS ON PRINTER
#
   SUBROUTINE OUTPUT (BUFR)
#
   INTEGER  PLINE, PAGE
   INTEGER JUNK, STRPUT
   CHARACTER BUFR(133), OUTBUF(61)
   COMMON / MAPPS / PLINE, PAGE
#
#
   IF (PLINE > PAGELENGTH \ BUFR(1) == FORMFEED)  [	#ADVANCE PAGE AND DO HEADER
      OUTBUF(1)=FORMFEED
      OUTBUF(2)=EOS
      JUNK=STRPUT (LUNOUT, OUTBUF, BLANK)		#ADVANCE PAGE
      OUTBUF(1)=BLANK
      JUNK=STRPUT (LUNOUT, OUTBUF, BLANK)
      JUNK=STRPUT (LUNOUT, OUTBUF, BLANK)		#BLANK LINES
      JUNK=STRPUT (LUNOUT, OUTBUF, BLANK)
      INCREMENT (PAGE)
      CALL SPAD (OUTBUF, 50)
      CALL DATE (OUTBUF(10))				#RSX!!!
      CALL TIME (OUTBUF(20))
      CALL SINSRT ("PAGE", OUTBUF(45))
      JUNK=SITOC (PAGE, OUTBUF(50), 4)
      JUNK=STRPUT (LUNOUT, OUTBUF, BLANK)		#PRINT THE HEADING
      OUTBUF(1)=BLANK
      OUTBUF(2)=EOS
      JUNK=STRPUT (LUNOUT, OUTBUF, BLANK)		#BLANK LINES
      JUNK=STRPUT (LUNOUT, OUTBUF, BLANK)
      PLINE=6
      IF (BUFR(1) == FORMFEED)
         RETURN					#DONE IT
      ]
   JUNK=STRPUT (LUNOUT, BUFR, BLANK)
   INCREMENT (PLINE)
#
   RETURN
   END
#$ REPORT - SUBROUTINE TO COLLECT MAPPS DATA
#
   SUBROUTINE REPORT 
#
   INTEGER STRGET, JUNK, EQLS
   CHARACTER BUFR(133)
#
   WHILE (STRGET(LUNIN,BUFR,132) != EOF) [
      IF (EQLS(BUFR,"FORTRAN IV STORAGE") == YES) [
         CALL OUTPUT ("  ")
         CALL OUTPUT ("  ")
         BUFR(40)=EOS
         CALL FOLD (BUFR(27))
         BUFR(40)=BLANK
         FOR (I=1; I < 27; INCREMENT(I))
            BUFR(I)='-'
         BUFR(27)=BLANK
         CALL OUTPUT (BUFR)
         ]
      ELSE IF (EQLS(BUFR,"COMMON BLOCK") == YES) [
         BUFR(21)=EOS
         BUFR(14)=EOS
         CALL FOLD(BUFR)
         BUFR(14)=BLANK
         CALL OUTPUT (BUFR)
         ]
      ELSE IF (EQLS(BUFR,"SUBROUTINES, FUNCTIONS") == YES) [
         BUFR(12)=COLON
         BUFR(13)=EOS
         CALL FOLD (BUFR)
         CALL OUTPUT (BUFR)
         JUNK=STRGET (LUNIN, BUFR, 132)
         JUNK=STRGET (LUNIN, BUFR, 132)
         WHILE (STRGET (LUNIN, BUFR, 132) > 3) [
            CALL COMPRS (BUFR)
            CALL OUTPUT (BUFR)
            ]
         ]
      OTHERWISE
         NEXT
      ]
   RETURN
   END