INPUT TO SFS - SEARCH FORTRAN SOURCE 12-APR-79 *LOGFILE 'C*' *LOGFILE ' SUBROUTINE' *LOGFILE ' FUNCTION' [360,200]ARAP.FTN ARAP ARAP IS MASTER FILE FOR FOLLOWING LOGICAL FILES, 346 RECORDS 1 FILES NO. OF RECORD CONSIDERED RECORDS OFFSET 1 CLRTAB 70 177 C* CLRTAB - CLEAR TABS TO CORRECT COLUMNS + NOTE ! TYPE COMMENTS 2 IBLUF 29 281 C* IBLUF - BYTE VECTOR LOOKUP 3 INDIRE 2 247 C* INDIRECT FILE OPEN 4 INDOP 32 249 SUBROUTINE INDOP (NIN, BSTR, NCH, IRCOD) 5 ISPC 16 30 C* ISPC - DETERMINE SPECIAL CHARACTER 6 LSTBV 11 310 SUBROUTINE LSTBV (IB, IV) 7 NIWIJ 8 22 FUNCTION NIWIJ (I, J) 8 PUTXT 61 46 SUBROUTINEPUTXT(BNAME,BEXT) 9 RVB 35 107 C* RVB - READ VIRTUAL BLOCK FROM DISK 10 SFCHR 11 11 C* SFCHR - CHARACTER FILL 11 SMCHR 11 0 C* SMCHR - MOVE CHARACTERS 12 STBLK 25 321 C* STBLK - STRIP BLANKS 13 WVB 35 142 C* WVB - WRITE VIRTUAL BLOCK FROM DISK 1 CLRTAB PAGE 1 12-APR-79 1: C* CLRTAB - CLEAR TABS TO CORRECT COLUMNS + NOTE ! TYPE COMMENTS 2: C 3: SUBROUTINE CLRTAB (BUFIN, LFORT) 4: C 5: C -CALL CLRTAB (BUFIN, LFORT) 6: C BUFIN - INPUT BUFFER OF 40 WORD LENGTH 7: C LFORT - .TRUE. = USE FORTRAN TYPE TABS 8: C .FALSE. = USE MOD 8 TABBING 9: C 10: C **NOTES** 11: C 1) IF LFORT IS .TRUE. THEN 12: C TAB FOLLOWED BY 0-9 IN COLS<=5 CONSTITUTES A 13: C CONTINUATION AND IS MOVED TO COL 6. 14: C TABS IN COMMENT CARDS USE MOD 8 ALGORITHM. 15: C ALL OTHER TABS COME OUT AS 1 BLANK. 16: C 17: C BUFIN IS OVERLAYED WITH BLANK PADDED IMAGE 18: C LFORT IS INPUT 19: C 20: IMPLICIT LOGICAL (L) 21: IMPLICIT BYTE (B) 22: C 23: DIMENSION BUFF(80), BUFIN(80) 24: DATA BTAB/9/ 25: C 26: J = 1 27: NEX = 0 28: CALL SFCHR (BUFF, 1, 80, ' ') 29: LCMT = BUFIN(1) .EQ. 'C' .AND. LFORT 30: LCMT = LCMT .OR. .NOT.LFORT 31: C 32: C SCAN INPUT RECORD 33: C 34: NC = IRNSC (BUFIN, 1, 80) 35: DO 200 I=1, NC 36: IF (.NOT.LCMT .AND. BUFIN(I).EQ.' 37: LTAB = BUFIN(I) .EQ. BTAB 38: LCONT = BUFIN(I+1).GE.'1' .AND. BUFIN(I+1).LE.'9' .AND. J.LE.5 39: LCONT = LCONT .AND. .NOT.LCMT 40: IF (.NOT.LTAB) GO TO 100 41: IF (LCMT) J = (J+7)/8*8 42: J = J + 1 43: IF (.NOT.LCMT .AND. J.LE.8) J = 7 44: IF (LCONT) J = 6 45: GO TO 200 46: C 47: 100 CONTINUE 48: IF (J .LE. 80) GO TO 120 49: WRITE (5, 520) BUFIN 50: 520 FORMAT (' ATTEMPT TO EXPAND BEYOND 80 COLS'/' ',80A1, 51: 1/' [TERMINATING SCAN ON THIS RECORD]') 52: GO TO 220 53: 120 BUFF(J) = BUFIN(I) 54: GO TO 190 55: C 56: 150 CONTINUE 57: LCMT = .TRUE. 58: NEX = J 1 CLRTAB PAGE 2 12-APR-79 59: 190 J = J + 1 60: 200 CONTINUE 61: C 62: C ! TYPE COMMENTS ARE OVERLAYED WITH BLANKS 63: C 64: 220 IF (NEX .EQ. 0) GO TO 250 65: CALL SFCHR (BUFF, NEX, 81-NEX, ' ') 66: C 67: 250 CONTINUE 68: CALL SMCHR (BUFF, 1, BUFIN, 1, 80) 69: RETURN 70: END 1 IBLUF PAGE 1 12-APR-79 1: C* IBLUF - BYTE VECTOR LOOKUP 2: C 3: FUNCTION IBLUF (BCHR, BVEC) 4: C 5: C BYTE LOOKUP FUNCTION 6: C 7: C INPUTS - 8: C BCHR - CHARACTER TO LOOKUP 9: C BVEC - CHAR VEC TO SEARCH, TERMINATED WITH A ZERO BYTE 10: C 11: C RETURNS 12: C IBLUF - POSITIVE , POSI WHERE FOUND 13: C - NEGATIVE OR 0, NOT FOUND 14: C 15: IMPLICIT BYTE (B) 16: C 17: DIMENSION BVEC(1) 18: C 19: IBLUF = 1 20: 100 CONTINUE 21: IF (BVEC(IBLUF) .EQ. 0) GO TO 200 22: IF (BVEC(IBLUF) .EQ. BCHR) GO TO 210 23: IBLUF = IBLUF + 1 24: GO TO 100 25: C 26: 200 CONTINUE 27: IBLUF = -1 28: 210 RETURN 29: END 1 INDIRE PAGE 1 12-APR-79 1: C* INDIRECT FILE OPEN 2: C 1 INDOP PAGE 1 12-APR-79 1: SUBROUTINE INDOP (NIN, BSTR, NCH, IRCOD) 2: C 3: C NIN = LUN FOR INDIRECT FILE, AN ATTEMP WILL BE MADE TO CLOSE 4: C ANYTHING PRESENTLY OPEN ON THIS LUN. 5: C BSTR = FILENAME STRING TO CHECK (@). 6: C NCH = NUMBER OF CHARACTERS IN STRING, MAX. 7: C IRCOD = RETURN CODE, 1 IF INDIRECT OPENED, 0 IF NOT 8: C 9: IMPLICIT BYTE (B) 10: BYTE BSTR(30), BTEMP(35) 11: C 12: DATA BTEMP/'S','Y','0',':',31*' '/ 13: DATA BAT/'@'/, BCOL/':'/ 14: C 15: IRCOD = 0 16: IP = 5 17: IS = 0 18: DO 10 I = 1, NCH 19: IF (BSTR(I) .EQ. BAT) IS = I 20: IF (BSTR(I) .EQ. BCOL) IP = 1 21: 10 CONTINUE 22: IF (IS .LE. 0) RETURN 23: C 24: CALL SMCHR (BSTR, IS+1, BTEMP, IP, 35-IP) 25: CALL PUTXT (BTEMP, '.CMD') 26: CALL CLOSE (NIN) 27: CALL FDBSET (NIN, 'READONLY') 28: CALL ASSIGN (NIN, BTEMP) 29: C 30: IRCOD = 1 31: RETURN 32: END 1 ISPC PAGE 1 12-APR-79 1: C* ISPC - DETERMINE SPECIAL CHARACTER 2: C 3: C DETERMINE IF CHARACTER IS NUMBER, SPECIAL, OR LETTER 4: C ICH IS GNXCH FORMAT. LEFT BYTE 0, RIGHT BYTE CHARACTER TO CHECK 5: C VALUES RETURNED 6: C -1 = ICH IS 0-9 7: C 0 = ICH IS A SPECIAL CHARACTER (*, &, ^ ETC.) 8: C +1 = ICH IS A-Z 9: C 10: FUNCTION ISPC (ICH) 11: ISPC = 1 12: IF (ICH.GE.48 .AND. ICH.LE.57) ISPC = -1 13: IF (ICH.GE.65 .AND. ICH.LE.90) ISPC = 0 14: RETURN 15: END 16: C PUTXT.FTN 13-SEP-77 15:20 1 LSTBV PAGE 1 12-APR-79 1: SUBROUTINE LSTBV (IB, IV) 2: C 3: C LSTBV - SET BIT VECTOR (BIT SET TO 1) 4: C 5: DIMENSION IV(1) 6: DATA NBPW/16/, MASK/1/ 7: INDEX = IB/NBPW + 1 8: IBIT = IB - (INDEX-1)*NBPW 9: IV(INDEX) = IOR(IV(INDEX), ISHFT(MASK,IBIT)) 10: RETURN 11: END 1 NIWIJ PAGE 1 12-APR-79 1: FUNCTION NIWIJ (I, J) 2: C 3: INTEGER*4 LOCF 4: C NIWIJ - NUMBER OF INTEGER WORDS FROM I TO J 5: C 6: NIWIJ = (LOCF(J) - LOCF(I))/2 7: RETURN 8: END 1 PUTXT PAGE 1 12-APR-79 1: SUBROUTINEPUTXT(BNAME,BEXT) 2: PARAMETERDARTH=36,VADER=4 3: BYTEBNAME(DARTH),BEXT(VADER) 4: LOGICALLDOT 5: LDOT=.FALSE. 6: NSEM=0 7: CONTINUE 8: I=1 9: 23000 IF(.NOT.(I.LE.DARTH))GOTO 23002 10: NEND=I 11: IF(.NOT.(BNAME(I).EQ.1H ))GOTO 23003 12: GOTO 23002 13: 23003 CONTINUE 14: IF(.NOT.(BNAME(I).EQ.1H.))GOTO 23005 15: LDOT=.TRUE. 16: GOTO 23006 17: 23005 CONTINUE 18: IF(.NOT.(BNAME(I).EQ.1H;))GOTO 23007 19: NSEM=I 20: 23007 CONTINUE 21: 23006 CONTINUE 22: 23001 I=I+1 23: GOTO 23000 24: 23002 CONTINUE 25: IF(.NOT.(.NOT.LDOT))GOTO 23009 26: MEND=0 27: CONTINUE 28: J=1 29: 23011 IF(.NOT.(J.LE.VADER))GOTO 23013 30: IF(.NOT.(BEXT(J).EQ.1H ))GOTO 23014 31: GOTO 23013 32: 23014 CONTINUE 33: MEND=J 34: 23012 J=J+1 35: GOTO 23011 36: 23013 CONTINUE 37: IF(.NOT.(MEND.GT.0))GOTO 23016 38: KPUT=NEND-1 39: IF(.NOT.(NSEM.GT.0))GOTO 23018 40: CONTINUE 41: K=MIN(KPUT,DARTH-MEND) 42: 23020 IF(.NOT.(K.GE.NSEM))GOTO 23022 43: BNAME(K+MEND)=BNAME(K) 44: 23021 K=K-1 45: GOTO 23020 46: 23022 CONTINUE 47: KPUT=NSEM-1 48: 23018 CONTINUE 49: CONTINUE 50: M=1 51: 23023 IF(.NOT.(M.LE.MIN(MEND,DARTH-KPUT)))GOTO 23025 52: BNAME(KPUT+M)=BEXT(M) 53: 23024 M=M+1 54: GOTO 23023 55: 23025 CONTINUE 56: NEND=MIN(MEND+NEND,DARTH) 57: 23016 CONTINUE 58: 23009 CONTINUE 1 PUTXT PAGE 2 12-APR-79 59: BNAME(NEND)=0 60: RETURN 61: END 1 RVB PAGE 1 12-APR-79 1: C* RVB - READ VIRTUAL BLOCK FROM DISK 2: C 3: SUBROUTINE RVB (ILUN, IBUF, NBLKS, NB, NERR) 4: C 5: C ILUN = LOGICAL UNIT NUMBER 6: C IBUF = DATA BUFFER 7: C NBLKS= NUMBER OF BLOCKS TO READ 8: C NB = INTEGER*2 BLOCK NUMBER TO BEGIN TRANSFER 9: C NERR = ERROR CODE +1 OK, ELSE BAD 10: C 11: DIMENSION IPARM(6), IOSTAT(2) 12: BYTE BSTAT(4) 13: EQUIVALENCE (IOSTAT, BSTAT) 14: DATA IORVB/"10400/ 15: C 16: CALL GETADR (IPARM, IBUF) 17: IPARM(2) = NBLKS*512 18: IPARM(4) = 0 19: IPARM(5) = NB 20: C 21: CALL WTQIO (IORVB, ILUN, 1, , IOSTAT, IPARM, IDSW) 22: C 23: C CHECK ERROR CODES 24: C 25: IF (IDSW .GT. 0) GO TO 100 26: WRITE (6, 505) IDSW 27: 505 FORMAT (' *** ERROR *** DSW =',I3) 28: CALL EXIT 29: C 30: 100 CONTINUE 31: NERR = BSTAT(1) 32: NB = NB + NBLKS 33: C 34: RETURN 35: END 1 SFCHR PAGE 1 12-APR-79 1: C* SFCHR - CHARACTER FILL 2: C 3: SUBROUTINE SFCHR (IV, IS, NCH, ICHR) 4: C 5: LOGICAL*1 IV(1), ICHR(2) 6: IF (NCH .LE. 0) RETURN 7: DO 10 I=1, NCH 8: IV(IS+I-1) = ICHR(1) 9: 10 CONTINUE 10: RETURN 11: END 1 SMCHR PAGE 1 12-APR-79 1: C* SMCHR - MOVE CHARACTERS 2: C 3: SUBROUTINE SMCHR (IV1, IS1, IV2, IS2, NCH) 4: C 5: LOGICAL*1 IV1(1), IV2(1) 6: IF (NCH .LE. 0) RETURN 7: DO 10 I=1, NCH 8: IV2(IS2+I-1) = IV1(IS1+I-1) 9: 10 CONTINUE 10: RETURN 11: END 1 STBLK PAGE 1 12-APR-79 1: C* STBLK - STRIP BLANKS 2: C 3: SUBROUTINE STBLK (BF, BT, NCH) 4: C 5: C BF - FROM VECTOR 6: C BT - TO VECTOR 7: C NCH - NUMBER OF CHARACTERS 8: C 9: C STRIP BLANKS FROM BF AND MOVE TO BT 10: C BF AND BT MAY BE THE SAVE VECTOR. 11: C 12: BYTE BT(1), BF(1) 13: C 14: J = 1 15: DO 100 I=1, NCH 16: IF (BF(I) .EQ. ' ') GO TO 100 17: BT(J) = BF(I) 18: J = J + 1 19: 100 CONTINUE 20: C 21: DO 200 I=J, NCH 22: 200 BT(I) = ' ' 23: C 24: RETURN 25: END 1 WVB PAGE 1 12-APR-79 1: C* WVB - WRITE VIRTUAL BLOCK FROM DISK 2: C 3: SUBROUTINE WVB (ILUN, IBUF, NBLKS, NB, NERR) 4: C 5: C ILUN = LOGICAL UNIT NUMBER 6: C IBUF = DATA BUFFER 7: C NBLKS= NUMBER OF BLOCKS TO READ 8: C NB = INTEGER*2 BLOCK NUMBER TO BEGIN TRANSFER 9: C NERR = ERROR CODE +1 OK, ELSE BAD 10: C 11: DIMENSION IPARM(6), IOSTAT(2), IBUF(1) 12: BYTE BSTAT(4) 13: EQUIVALENCE (IOSTAT, BSTAT) 14: DATA IOWVB/"11000/ 15: C 16: CALL GETADR (IPARM, IBUF) 17: IPARM(2) = NBLKS*512 18: IPARM(4) = 0 19: IPARM(5) = NB 20: C 21: CALL WTQIO (IOWVB, ILUN, 1, , IOSTAT, IPARM, IDSW) 22: C 23: C CHECK ERROR CODES 24: C 25: IF (IDSW .GT. 0) GO TO 100 26: WRITE (6, 505) IDSW 27: 505 FORMAT (' *** ERROR *** DSW =',I3) 28: CALL EXIT 29: C 30: 100 CONTINUE 31: NERR = BSTAT(1) 32: NB = NB + NBLKS 33: C 34: RETURN 35: END 345 RECORDS PROCESSED 561 WORDS USED OF 12000 AVAILABLE FOR VARIABLE NAME LIST, (NCHR/2 + 4) WORDS PER VARIABLE 355 RECORDS USED OF 32766 AVAILABLE FOR VARIABLE REFERENCE FILE 1 PAGE 1 12-APR-79 VARIABLE FILES USING THAT VARIABLE ASSIGN INDOP BAT INDOP BCHR IBLUF BCOL INDOP BEXT PUTXT BF STBLK BNAME PUTXT BSTAT RVB WVB BSTR INDOP BT STBLK BTAB CLRTAB BTEMP INDOP BUFF CLRTAB BUFIN CLRTAB BVEC IBLUF C CLRTAB CLOSE INDOP CLRTAB CLRTAB CMD INDOP DARTH PUTXT FDBSET INDOP GETADR RVB WVB H PUTXT I CLRTAB INDOP NIWIJ PUTXT SFCHR SMCHR STBLK IB LSTBV IBIT LSTBV IBLUF IBLUF IBUF RVB WVB ICH ISPC ICHR SFCHR IDSW RVB WVB ILUN RVB WVB INDEX LSTBV INDOP INDOP IOR LSTBV IORVB RVB IOSTAT RVB WVB IOWVB WVB IP INDOP IPARM RVB WVB IRCOD INDOP IRNSC CLRTAB IS INDOP SFCHR IS1 SMCHR IS2 SMCHR ISHFT LSTBV ISPC ISPC IV LSTBV SFCHR IV1 SMCHR IV2 SMCHR J CLRTAB NIWIJ PUTXT STBLK K PUTXT KPUT PUTXT LCMT CLRTAB LCONT CLRTAB LDOT PUTXT 1 PAGE 2 12-APR-79 LFORT CLRTAB LOCF NIWIJ LSTBV LSTBV LTAB CLRTAB M PUTXT MASK LSTBV MEND PUTXT MIN PUTXT NB RVB WVB NBLKS RVB WVB NBPW LSTBV NC CLRTAB NCH INDOP SFCHR SMCHR STBLK NEND PUTXT NERR RVB WVB NEX CLRTAB NIN INDOP NIWIJ NIWIJ NSEM PUTXT PUTXT INDOP PUTXT READONLY INDOP RVB RVB SFCHR CLRTAB SFCHR SMCHR CLRTAB INDOP SMCHR STBLK STBLK VADER PUTXT WTQIO RVB WVB WVB WVB 84 VARIABLES 1 PAGE 1 12-APR-79 FILE VARIABLE LINE NO. STATEMENT INDOP ASSIGN 28 CALL ASSIGN (NIN, BTEMP) INDOP BAT 13 DATA BAT/'@'/, BCOL/':'/ BAT 19 IF (BSTR(I) .EQ. BAT) IS = I IBLUF BCHR 3 FUNCTION IBLUF (BCHR, BVEC) BCHR 22 IF (BVEC(IBLUF) .EQ. BCHR) GO TO 210 INDOP BCOL 13 DATA BAT/'@'/, BCOL/':'/ BCOL 20 IF (BSTR(I) .EQ. BCOL) IP = 1 PUTXT BEXT 1 SUBROUTINEPUTXT(BNAME,BEXT) BEXT 3 BYTEBNAME(DARTH),BEXT(VADER) BEXT 30 IF(.NOT.(BEXT(J).EQ.1H ))GOTO 23014 BEXT 52 BNAME(KPUT+M)=BEXT(M) STBLK BF 3 SUBROUTINE STBLK (BF, BT, NCH) BF 12 BYTE BT(1), BF(1) BF 16 IF (BF(I) .EQ. ' ') GO TO 100 BF 17 BT(J) = BF(I) PUTXT BNAME 1 SUBROUTINEPUTXT(BNAME,BEXT) BNAME 3 BYTEBNAME(DARTH),BEXT(VADER) BNAME 11 IF(.NOT.(BNAME(I).EQ.1H ))GOTO 23003 BNAME 14 IF(.NOT.(BNAME(I).EQ.1H.))GOTO 23005 BNAME 18 IF(.NOT.(BNAME(I).EQ.1H;))GOTO 23007 BNAME 43 BNAME(K+MEND)=BNAME(K) BNAME 52 BNAME(KPUT+M)=BEXT(M) BNAME 59 BNAME(NEND)=0 RVB BSTAT 12 BYTE BSTAT(4) BSTAT 13 EQUIVALENCE (IOSTAT, BSTAT) BSTAT 31 NERR = BSTAT(1) WVB BSTAT 12 BYTE BSTAT(4) BSTAT 13 EQUIVALENCE (IOSTAT, BSTAT) BSTAT 31 NERR = BSTAT(1) INDOP BSTR 1 SUBROUTINE INDOP (NIN, BSTR, NCH, IRCOD) BSTR 10 BYTE BSTR(30), BTEMP(35) BSTR 19 IF (BSTR(I) .EQ. BAT) IS = I BSTR 20 IF (BSTR(I) .EQ. BCOL) IP = 1 BSTR 24 CALL SMCHR (BSTR, IS+1, BTEMP, IP, 35-IP) STBLK BT 3 SUBROUTINE STBLK (BF, BT, NCH) BT 12 BYTE BT(1), BF(1) BT 17 BT(J) = BF(I) BT 22 200 BT(I) = ' ' CLRTAB BTAB 24 DATA BTAB/9/ BTAB 37 LTAB = BUFIN(I) .EQ. BTAB INDOP BTEMP 10 BYTE BSTR(30), BTEMP(35) BTEMP 12 DATA BTEMP/'S','Y','0',':',31*' '/ BTEMP 24 CALL SMCHR (BSTR, IS+1, BTEMP, IP, 35-IP) BTEMP 25 CALL PUTXT (BTEMP, '.CMD') 1 PAGE 2 12-APR-79 BTEMP 28 CALL ASSIGN (NIN, BTEMP) CLRTAB BUFF 23 DIMENSION BUFF(80), BUFIN(80) BUFF 28 CALL SFCHR (BUFF, 1, 80, ' ') BUFF 53 120 BUFF(J) = BUFIN(I) BUFF 65 CALL SFCHR (BUFF, NEX, 81-NEX, ' ') BUFF 68 CALL SMCHR (BUFF, 1, BUFIN, 1, 80) CLRTAB BUFIN 3 SUBROUTINE CLRTAB (BUFIN, LFORT) BUFIN 23 DIMENSION BUFF(80), BUFIN(80) BUFIN 29 LCMT = BUFIN(1) .EQ. 'C' .AND. LFORT BUFIN 34 NC = IRNSC (BUFIN, 1, 80) BUFIN 37 LTAB = BUFIN(I) .EQ. BTAB BUFIN 38 LCONT = BUFIN(I+1).GE.'1' .AND. BUFIN(I+1).LE.'9' .AND. J.LE.5 BUFIN 49 WRITE (5, 520) BUFIN BUFIN 53 120 BUFF(J) = BUFIN(I) BUFIN 68 CALL SMCHR (BUFF, 1, BUFIN, 1, 80) IBLUF BVEC 3 FUNCTION IBLUF (BCHR, BVEC) BVEC 17 DIMENSION BVEC(1) BVEC 21 IF (BVEC(IBLUF) .EQ. 0) GO TO 200 BVEC 22 IF (BVEC(IBLUF) .EQ. BCHR) GO TO 210 CLRTAB C 29 LCMT = BUFIN(1) .EQ. 'C' .AND. LFORT INDOP CLOSE 26 CALL CLOSE (NIN) CLRTAB CLRTAB 3 SUBROUTINE CLRTAB (BUFIN, LFORT) INDOP CMD 25 CALL PUTXT (BTEMP, '.CMD') PUTXT DARTH 2 PARAMETERDARTH=36,VADER=4 DARTH 3 BYTEBNAME(DARTH),BEXT(VADER) DARTH 9 23000 IF(.NOT.(I.LE.DARTH))GOTO 23002 DARTH 41 K=MIN(KPUT,DARTH-MEND) DARTH 51 23023 IF(.NOT.(M.LE.MIN(MEND,DARTH-KPUT)))GOTO 23025 DARTH 56 NEND=MIN(MEND+NEND,DARTH) INDOP FDBSET 27 CALL FDBSET (NIN, 'READONLY') RVB GETADR 16 CALL GETADR (IPARM, IBUF) WVB GETADR 16 CALL GETADR (IPARM, IBUF) PUTXT H 11 IF(.NOT.(BNAME(I).EQ.1H ))GOTO 23003 H 14 IF(.NOT.(BNAME(I).EQ.1H.))GOTO 23005 H 18 IF(.NOT.(BNAME(I).EQ.1H;))GOTO 23007 H 30 IF(.NOT.(BEXT(J).EQ.1H ))GOTO 23014 CLRTAB I 35 DO 200 I=1, NC I 37 LTAB = BUFIN(I) .EQ. BTAB I 38 LCONT = BUFIN(I+1).GE.'1' .AND. BUFIN(I+1).LE.'9' .AND. J.LE.5 I 53 120 BUFF(J) = BUFIN(I) INDOP I 18 DO 10 I = 1, NCH I 19 IF (BSTR(I) .EQ. BAT) IS = I I 20 IF (BSTR(I) .EQ. BCOL) IP = 1 1 PAGE 3 12-APR-79 NIWIJ I 1 FUNCTION NIWIJ (I, J) I 6 NIWIJ = (LOCF(J) - LOCF(I))/2 PUTXT I 8 I=1 I 9 23000 IF(.NOT.(I.LE.DARTH))GOTO 23002 I 10 NEND=I I 11 IF(.NOT.(BNAME(I).EQ.1H ))GOTO 23003 I 14 IF(.NOT.(BNAME(I).EQ.1H.))GOTO 23005 I 18 IF(.NOT.(BNAME(I).EQ.1H;))GOTO 23007 I 19 NSEM=I I 22 23001 I=I+1 SFCHR I 7 DO 10 I=1, NCH I 8 IV(IS+I-1) = ICHR(1) SMCHR I 7 DO 10 I=1, NCH I 8 IV2(IS2+I-1) = IV1(IS1+I-1) STBLK I 15 DO 100 I=1, NCH I 16 IF (BF(I) .EQ. ' ') GO TO 100 I 17 BT(J) = BF(I) I 21 DO 200 I=J, NCH I 22 200 BT(I) = ' ' LSTBV IB 1 SUBROUTINE LSTBV (IB, IV) IB 7 INDEX = IB/NBPW + 1 IB 8 IBIT = IB - (INDEX-1)*NBPW LSTBV IBIT 8 IBIT = IB - (INDEX-1)*NBPW IBIT 9 IV(INDEX) = IOR(IV(INDEX), ISHFT(MASK,IBIT)) IBLUF IBLUF 3 FUNCTION IBLUF (BCHR, BVEC) IBLUF 19 IBLUF = 1 IBLUF 21 IF (BVEC(IBLUF) .EQ. 0) GO TO 200 IBLUF 22 IF (BVEC(IBLUF) .EQ. BCHR) GO TO 210 IBLUF 23 IBLUF = IBLUF + 1 IBLUF 27 IBLUF = -1 RVB IBUF 3 SUBROUTINE RVB (ILUN, IBUF, NBLKS, NB, NERR) IBUF 16 CALL GETADR (IPARM, IBUF) WVB IBUF 3 SUBROUTINE WVB (ILUN, IBUF, NBLKS, NB, NERR) IBUF 11 DIMENSION IPARM(6), IOSTAT(2), IBUF(1) IBUF 16 CALL GETADR (IPARM, IBUF) ISPC ICH 10 FUNCTION ISPC (ICH) ICH 12 IF (ICH.GE.48 .AND. ICH.LE.57) ISPC = -1 ICH 13 IF (ICH.GE.65 .AND. ICH.LE.90) ISPC = 0 SFCHR ICHR 3 SUBROUTINE SFCHR (IV, IS, NCH, ICHR) ICHR 5 LOGICAL*1 IV(1), ICHR(2) ICHR 8 IV(IS+I-1) = ICHR(1) RVB IDSW 21 CALL WTQIO (IORVB, ILUN, 1, , IOSTAT, IPARM, IDSW) IDSW 25 IF (IDSW .GT. 0) GO TO 100 IDSW 26 WRITE (6, 505) IDSW 1 PAGE 4 12-APR-79 WVB IDSW 21 CALL WTQIO (IOWVB, ILUN, 1, , IOSTAT, IPARM, IDSW) IDSW 25 IF (IDSW .GT. 0) GO TO 100 IDSW 26 WRITE (6, 505) IDSW RVB ILUN 3 SUBROUTINE RVB (ILUN, IBUF, NBLKS, NB, NERR) ILUN 21 CALL WTQIO (IORVB, ILUN, 1, , IOSTAT, IPARM, IDSW) WVB ILUN 3 SUBROUTINE WVB (ILUN, IBUF, NBLKS, NB, NERR) ILUN 21 CALL WTQIO (IOWVB, ILUN, 1, , IOSTAT, IPARM, IDSW) LSTBV INDEX 7 INDEX = IB/NBPW + 1 INDEX 8 IBIT = IB - (INDEX-1)*NBPW INDEX 9 IV(INDEX) = IOR(IV(INDEX), ISHFT(MASK,IBIT)) INDOP INDOP 1 SUBROUTINE INDOP (NIN, BSTR, NCH, IRCOD) LSTBV IOR 9 IV(INDEX) = IOR(IV(INDEX), ISHFT(MASK,IBIT)) RVB IORVB 14 DATA IORVB/"10400/ IORVB 21 CALL WTQIO (IORVB, ILUN, 1, , IOSTAT, IPARM, IDSW) RVB IOSTAT 11 DIMENSION IPARM(6), IOSTAT(2) IOSTAT 13 EQUIVALENCE (IOSTAT, BSTAT) IOSTAT 21 CALL WTQIO (IORVB, ILUN, 1, , IOSTAT, IPARM, IDSW) WVB IOSTAT 11 DIMENSION IPARM(6), IOSTAT(2), IBUF(1) IOSTAT 13 EQUIVALENCE (IOSTAT, BSTAT) IOSTAT 21 CALL WTQIO (IOWVB, ILUN, 1, , IOSTAT, IPARM, IDSW) WVB IOWVB 14 DATA IOWVB/"11000/ IOWVB 21 CALL WTQIO (IOWVB, ILUN, 1, , IOSTAT, IPARM, IDSW) INDOP IP 16 IP = 5 IP 20 IF (BSTR(I) .EQ. BCOL) IP = 1 IP 24 CALL SMCHR (BSTR, IS+1, BTEMP, IP, 35-IP) RVB IPARM 11 DIMENSION IPARM(6), IOSTAT(2) IPARM 16 CALL GETADR (IPARM, IBUF) IPARM 17 IPARM(2) = NBLKS*512 IPARM 18 IPARM(4) = 0 IPARM 19 IPARM(5) = NB IPARM 21 CALL WTQIO (IORVB, ILUN, 1, , IOSTAT, IPARM, IDSW) WVB IPARM 11 DIMENSION IPARM(6), IOSTAT(2), IBUF(1) IPARM 16 CALL GETADR (IPARM, IBUF) IPARM 17 IPARM(2) = NBLKS*512 IPARM 18 IPARM(4) = 0 IPARM 19 IPARM(5) = NB IPARM 21 CALL WTQIO (IOWVB, ILUN, 1, , IOSTAT, IPARM, IDSW) INDOP IRCOD 1 SUBROUTINE INDOP (NIN, BSTR, NCH, IRCOD) IRCOD 15 IRCOD = 0 IRCOD 30 IRCOD = 1 CLRTAB IRNSC 34 NC = IRNSC (BUFIN, 1, 80) INDOP IS 17 IS = 0 1 PAGE 5 12-APR-79 IS 19 IF (BSTR(I) .EQ. BAT) IS = I IS 22 IF (IS .LE. 0) RETURN IS 24 CALL SMCHR (BSTR, IS+1, BTEMP, IP, 35-IP) SFCHR IS 3 SUBROUTINE SFCHR (IV, IS, NCH, ICHR) IS 8 IV(IS+I-1) = ICHR(1) SMCHR IS1 3 SUBROUTINE SMCHR (IV1, IS1, IV2, IS2, NCH) IS1 8 IV2(IS2+I-1) = IV1(IS1+I-1) SMCHR IS2 3 SUBROUTINE SMCHR (IV1, IS1, IV2, IS2, NCH) IS2 8 IV2(IS2+I-1) = IV1(IS1+I-1) LSTBV ISHFT 9 IV(INDEX) = IOR(IV(INDEX), ISHFT(MASK,IBIT)) ISPC ISPC 10 FUNCTION ISPC (ICH) ISPC 11 ISPC = 1 ISPC 12 IF (ICH.GE.48 .AND. ICH.LE.57) ISPC = -1 ISPC 13 IF (ICH.GE.65 .AND. ICH.LE.90) ISPC = 0 LSTBV IV 1 SUBROUTINE LSTBV (IB, IV) IV 5 DIMENSION IV(1) IV 9 IV(INDEX) = IOR(IV(INDEX), ISHFT(MASK,IBIT)) SFCHR IV 3 SUBROUTINE SFCHR (IV, IS, NCH, ICHR) IV 5 LOGICAL*1 IV(1), ICHR(2) IV 8 IV(IS+I-1) = ICHR(1) SMCHR IV1 3 SUBROUTINE SMCHR (IV1, IS1, IV2, IS2, NCH) IV1 5 LOGICAL*1 IV1(1), IV2(1) IV1 8 IV2(IS2+I-1) = IV1(IS1+I-1) SMCHR IV2 3 SUBROUTINE SMCHR (IV1, IS1, IV2, IS2, NCH) IV2 5 LOGICAL*1 IV1(1), IV2(1) IV2 8 IV2(IS2+I-1) = IV1(IS1+I-1) CLRTAB J 26 J = 1 J 38 LCONT = BUFIN(I+1).GE.'1' .AND. BUFIN(I+1).LE.'9' .AND. J.LE.5 J 41 IF (LCMT) J = (J+7)/8*8 J 42 J = J + 1 J 43 IF (.NOT.LCMT .AND. J.LE.8) J = 7 J 44 IF (LCONT) J = 6 J 48 IF (J .LE. 80) GO TO 120 J 53 120 BUFF(J) = BUFIN(I) J 58 NEX = J J 59 190 J = J + 1 NIWIJ J 1 FUNCTION NIWIJ (I, J) J 6 NIWIJ = (LOCF(J) - LOCF(I))/2 PUTXT J 28 J=1 J 29 23011 IF(.NOT.(J.LE.VADER))GOTO 23013 J 30 IF(.NOT.(BEXT(J).EQ.1H ))GOTO 23014 J 33 MEND=J J 34 23012 J=J+1 STBLK J 14 J = 1 J 17 BT(J) = BF(I) 1 PAGE 6 12-APR-79 J 18 J = J + 1 J 21 DO 200 I=J, NCH PUTXT K 41 K=MIN(KPUT,DARTH-MEND) K 42 23020 IF(.NOT.(K.GE.NSEM))GOTO 23022 K 43 BNAME(K+MEND)=BNAME(K) K 44 23021 K=K-1 PUTXT KPUT 38 KPUT=NEND-1 KPUT 41 K=MIN(KPUT,DARTH-MEND) KPUT 47 KPUT=NSEM-1 KPUT 51 23023 IF(.NOT.(M.LE.MIN(MEND,DARTH-KPUT)))GOTO 23025 KPUT 52 BNAME(KPUT+M)=BEXT(M) CLRTAB LCMT 29 LCMT = BUFIN(1) .EQ. 'C' .AND. LFORT LCMT 30 LCMT = LCMT .OR. .NOT.LFORT LCMT 39 LCONT = LCONT .AND. .NOT.LCMT LCMT 41 IF (LCMT) J = (J+7)/8*8 LCMT 43 IF (.NOT.LCMT .AND. J.LE.8) J = 7 LCMT 57 LCMT = .TRUE. CLRTAB LCONT 38 LCONT = BUFIN(I+1).GE.'1' .AND. BUFIN(I+1).LE.'9' .AND. J.LE.5 LCONT 39 LCONT = LCONT .AND. .NOT.LCMT LCONT 44 IF (LCONT) J = 6 PUTXT LDOT 4 LOGICALLDOT LDOT 5 LDOT=.FALSE. LDOT 15 LDOT=.TRUE. LDOT 25 IF(.NOT.(.NOT.LDOT))GOTO 23009 CLRTAB LFORT 3 SUBROUTINE CLRTAB (BUFIN, LFORT) LFORT 29 LCMT = BUFIN(1) .EQ. 'C' .AND. LFORT LFORT 30 LCMT = LCMT .OR. .NOT.LFORT NIWIJ LOCF 3 INTEGER*4 LOCF LOCF 6 NIWIJ = (LOCF(J) - LOCF(I))/2 LSTBV LSTBV 1 SUBROUTINE LSTBV (IB, IV) CLRTAB LTAB 37 LTAB = BUFIN(I) .EQ. BTAB LTAB 40 IF (.NOT.LTAB) GO TO 100 PUTXT M 50 M=1 M 51 23023 IF(.NOT.(M.LE.MIN(MEND,DARTH-KPUT)))GOTO 23025 M 52 BNAME(KPUT+M)=BEXT(M) M 53 23024 M=M+1 LSTBV MASK 6 DATA NBPW/16/, MASK/1/ MASK 9 IV(INDEX) = IOR(IV(INDEX), ISHFT(MASK,IBIT)) PUTXT MEND 26 MEND=0 MEND 33 MEND=J MEND 37 IF(.NOT.(MEND.GT.0))GOTO 23016 MEND 41 K=MIN(KPUT,DARTH-MEND) MEND 43 BNAME(K+MEND)=BNAME(K) MEND 51 23023 IF(.NOT.(M.LE.MIN(MEND,DARTH-KPUT)))GOTO 23025 MEND 56 NEND=MIN(MEND+NEND,DARTH) 1 PAGE 7 12-APR-79 PUTXT MIN 41 K=MIN(KPUT,DARTH-MEND) MIN 51 23023 IF(.NOT.(M.LE.MIN(MEND,DARTH-KPUT)))GOTO 23025 MIN 56 NEND=MIN(MEND+NEND,DARTH) RVB NB 3 SUBROUTINE RVB (ILUN, IBUF, NBLKS, NB, NERR) NB 19 IPARM(5) = NB NB 32 NB = NB + NBLKS WVB NB 3 SUBROUTINE WVB (ILUN, IBUF, NBLKS, NB, NERR) NB 19 IPARM(5) = NB NB 32 NB = NB + NBLKS RVB NBLKS 3 SUBROUTINE RVB (ILUN, IBUF, NBLKS, NB, NERR) NBLKS 17 IPARM(2) = NBLKS*512 NBLKS 32 NB = NB + NBLKS WVB NBLKS 3 SUBROUTINE WVB (ILUN, IBUF, NBLKS, NB, NERR) NBLKS 17 IPARM(2) = NBLKS*512 NBLKS 32 NB = NB + NBLKS LSTBV NBPW 6 DATA NBPW/16/, MASK/1/ NBPW 7 INDEX = IB/NBPW + 1 NBPW 8 IBIT = IB - (INDEX-1)*NBPW CLRTAB NC 34 NC = IRNSC (BUFIN, 1, 80) NC 35 DO 200 I=1, NC INDOP NCH 1 SUBROUTINE INDOP (NIN, BSTR, NCH, IRCOD) NCH 18 DO 10 I = 1, NCH SFCHR NCH 3 SUBROUTINE SFCHR (IV, IS, NCH, ICHR) NCH 6 IF (NCH .LE. 0) RETURN NCH 7 DO 10 I=1, NCH SMCHR NCH 3 SUBROUTINE SMCHR (IV1, IS1, IV2, IS2, NCH) NCH 6 IF (NCH .LE. 0) RETURN NCH 7 DO 10 I=1, NCH STBLK NCH 3 SUBROUTINE STBLK (BF, BT, NCH) NCH 15 DO 100 I=1, NCH NCH 21 DO 200 I=J, NCH PUTXT NEND 10 NEND=I NEND 38 KPUT=NEND-1 NEND 56 NEND=MIN(MEND+NEND,DARTH) NEND 59 BNAME(NEND)=0 RVB NERR 3 SUBROUTINE RVB (ILUN, IBUF, NBLKS, NB, NERR) NERR 31 NERR = BSTAT(1) WVB NERR 3 SUBROUTINE WVB (ILUN, IBUF, NBLKS, NB, NERR) NERR 31 NERR = BSTAT(1) CLRTAB NEX 27 NEX = 0 NEX 58 NEX = J NEX 64 220 IF (NEX .EQ. 0) GO TO 250 NEX 65 CALL SFCHR (BUFF, NEX, 81-NEX, ' ') 1 PAGE 8 12-APR-79 INDOP NIN 1 SUBROUTINE INDOP (NIN, BSTR, NCH, IRCOD) NIN 26 CALL CLOSE (NIN) NIN 27 CALL FDBSET (NIN, 'READONLY') NIN 28 CALL ASSIGN (NIN, BTEMP) NIWIJ NIWIJ 1 FUNCTION NIWIJ (I, J) NIWIJ 6 NIWIJ = (LOCF(J) - LOCF(I))/2 PUTXT NSEM 6 NSEM=0 NSEM 19 NSEM=I NSEM 39 IF(.NOT.(NSEM.GT.0))GOTO 23018 NSEM 42 23020 IF(.NOT.(K.GE.NSEM))GOTO 23022 NSEM 47 KPUT=NSEM-1 INDOP PUTXT 25 CALL PUTXT (BTEMP, '.CMD') PUTXT PUTXT 1 SUBROUTINEPUTXT(BNAME,BEXT) INDOP READONLY 27 CALL FDBSET (NIN, 'READONLY') RVB RVB 3 SUBROUTINE RVB (ILUN, IBUF, NBLKS, NB, NERR) CLRTAB SFCHR 28 CALL SFCHR (BUFF, 1, 80, ' ') SFCHR 65 CALL SFCHR (BUFF, NEX, 81-NEX, ' ') SFCHR SFCHR 3 SUBROUTINE SFCHR (IV, IS, NCH, ICHR) CLRTAB SMCHR 68 CALL SMCHR (BUFF, 1, BUFIN, 1, 80) INDOP SMCHR 24 CALL SMCHR (BSTR, IS+1, BTEMP, IP, 35-IP) SMCHR SMCHR 3 SUBROUTINE SMCHR (IV1, IS1, IV2, IS2, NCH) STBLK STBLK 3 SUBROUTINE STBLK (BF, BT, NCH) PUTXT VADER 2 PARAMETERDARTH=36,VADER=4 VADER 3 BYTEBNAME(DARTH),BEXT(VADER) VADER 29 23011 IF(.NOT.(J.LE.VADER))GOTO 23013 RVB WTQIO 21 CALL WTQIO (IORVB, ILUN, 1, , IOSTAT, IPARM, IDSW) WVB WTQIO 21 CALL WTQIO (IOWVB, ILUN, 1, , IOSTAT, IPARM, IDSW) WVB WVB 3 SUBROUTINE WVB (ILUN, IBUF, NBLKS, NB, NERR)