![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to INSTMT.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / pfort|
Return to INSTMT.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: SUBROUTINE INSTMT(EOF, NCARD) ! 2: LOGICAL ILLEG, ILHOL, ILCONT ! 3: LOGICAL NEWRD, EOF, CONT, OPT, P1ERR ! 4: INTEGER PSTMT, CARD(80), OUTUT, BLK, STATE, HCOUNT, STMT ! 5: INTEGER SYMLEN, OUTUT2, OUTUT3, OUTUT4 ! 6: DIMENSION IBR(5) ! 7: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 8: COMMON /OPTNS/ OPT(5), P1ERR ! 9: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 10: * OUTUT4 ! 11: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 12: DATA NEWRD /.TRUE./ ! 13: DATA IBR(1), IBR(2), IBR(3), IBR(4), IBR(5) /1H*,1HC,1H.,1H0,1H / ! 14: DATA CARD(1) /1H / ! 15: C ! 16: C ROUTINE INPUTS AN ENTIRE FORTRAN STATEMENT. IT IS PASSED 1 CHAR ! 17: C PER ELEMENT IN THE ARRAY STMT. ! 18: C IN SHOULD BE CALLED AGAIN IF ERR IS TRUE. ! 19: C EACH CARD IS WRITTEN OUT BEFORE BEING PARSED. ! 20: C IN DEBLANKS CARDS USES THE VARIABLE STATE TO FIND ! 21: C HOLLERITHS: ! 22: C STATE = 0.....LOOK FOR BREAK CHAR ! 23: C 1.....HAVE BREAK CHAR AND NEED DIGIT ! 24: C 2.....HAVE DIGIT AND NEED DIGIT OR "H" ! 25: C 3....NEED TO SKIP OVER THESE CHARS, PART OF HOLLERITH ! 26: C NOTE: USE "90" AS AN END OF STMT MARKER ! 27: C ! 28: C NEWRD IS TRUE IF A NEW CARD IS NECESSARY; ELSE CARD IN BUFFER ! 29: C IS USED. EOF IS TRUE WHEN END-OF-FILE CARD ("." IN COL 1) ! 30: C IS READ NCARD GIVES # OF CARDS READ FOR THIS STMT ! 31: C ! 32: 10 NOST = NOST + 1 ! 33: STATE = 0 ! 34: NSTMT = 0 ! 35: ILLEG = .FALSE. ! 36: ILCONT = .FALSE. ! 37: ILHOL = .FALSE. ! 38: NCARD = 0 ! 39: CONT = .FALSE. ! 40: 20 IF (NEWRD) CALL IN(CARD, INUT) ! 41: IF (CARD(1).NE.IBR(2) .OR. CARD(2).NE.IBR(1)) GO TO 40 ! 42: C ! 43: C DEAL WITH OPTIONS CARD ! 44: C ! 45: IF (CONT) GO TO 50 ! 46: CALL INOPT(CARD) ! 47: 30 IF (OPT(4)) WRITE (OUTUT,99999) CARD ! 48: 99999 FORMAT (11X, 80A1) ! 49: NEWRD = .TRUE. ! 50: GO TO 20 ! 51: 40 IF (CARD(1).NE.IBR(2)) GO TO 70 ! 52: C ! 53: C DEAL WITH COMMENT CARD ! 54: C ! 55: IF (.NOT.CONT) GO TO 30 ! 56: C ! 57: C HAVE COMPLETED STMT ! 58: C ! 59: 50 NEWRD = .FALSE. ! 60: NSTMT = NSTMT + 1 ! 61: STMT(NSTMT) = 90 ! 62: 60 IF (ILLEG) CALL ERROR1( ! 63: * 40H WARNING - NON-FORTRAN CHARACTER IGNORED, 40) ! 64: IF (ILHOL) CALL ERROR1( ! 65: * 46H WARNING - NON-FORTRAN CHARACTER IN HOLLERITH , 46) ! 66: IF (ILCONT) CALL ERROR1( ! 67: * 45H WARNING - NON-FORTRAN CONTINUATION CHARACTER, 45) ! 68: RETURN ! 69: 70 IF (CARD(1).NE.IBR(3)) GO TO 80 ! 70: C ! 71: C HAVE EOF ! 72: C ! 73: IF (CONT) GO TO 50 ! 74: EOF = .TRUE. ! 75: GO TO 60 ! 76: 80 IF (CARD(6).EQ.IBR(4) .OR. CARD(6).EQ.IBR(5)) GO TO 100 ! 77: C ! 78: C DEAL WITH CONTINUATION CARD ! 79: C ! 80: II = MAPCHR(CARD(6),ILCONT) ! 81: IF (CONT) GO TO 110 ! 82: CALL ERROR1(40H WARNING - CONTINUATION NOT ALLOWED HERE, 40) ! 83: C ! 84: C FLUSH TO NEXT NONCONTINUATION CARD ! 85: C ! 86: 90 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD ! 87: 99998 FORMAT (1H , I5, 5X, 80A1) ! 88: CALL IN(CARD, INUT) ! 89: IF (CARD(1).NE.IBR(1) .AND. CARD(1).NE.IBR(2) .AND. ! 90: * CARD(1).NE.IBR(3) .AND. CARD(6).NE.IBR(4) .AND. ! 91: * CARD(6).NE.IBR(5)) GO TO 90 ! 92: NEWRD = .FALSE. ! 93: GO TO 10 ! 94: C ! 95: C DEAL WITH A NON-CONTINUATION CARD ! 96: C ! 97: 100 IF (CONT) GO TO 50 ! 98: C DEAL WITH A LEGAL CONTIN OR NONCONTIN CARD ! 99: 110 NCARD = NCARD + 1 ! 100: IF (NCARD.LT.21) GO TO 120 ! 101: CALL ERROR1(33H WARNING - TOO MANY CONTINUATIONS, 33) ! 102: GO TO 90 ! 103: 120 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD ! 104: NEWRD = .TRUE. ! 105: BLK = 0 ! 106: IF (NSTMT.NE.0) GO TO 150 ! 107: DO 130 I=1,5 ! 108: NSTMT = NSTMT + 1 ! 109: STMT(NSTMT) = MAPCHR(CARD(I),ILLEG) ! 110: 130 CONTINUE ! 111: 140 I = 7 ! 112: GO TO 180 ! 113: 150 DO 160 I=1,5 ! 114: IF (MAPCHR(CARD(I),ILLEG).NE.69) GO TO 170 ! 115: 160 CONTINUE ! 116: GO TO 140 ! 117: 170 CALL ERROR1(40H WARNING - ILLEGAL LABEL WILL BE IGNORED, 40) ! 118: GO TO 140 ! 119: 180 IF (I.LE.72) GO TO 200 ! 120: C ! 121: C AFTER TRANSLATE CARD CHECK FOR BLANK CARD ! 122: C AND GO BACK FOR A CONTINUATION CARD ! 123: C ! 124: IF (BLK.NE.66) GO TO 190 ! 125: CALL ERROR1(33H WARNING - BLANK CARD ENCOUNTERED, 33) ! 126: GO TO 90 ! 127: 190 CONT = .TRUE. ! 128: GO TO 20 ! 129: 200 IF (STATE.NE.3) GO TO 210 ! 130: C ! 131: C STATE 3 --ARE PROCESSING A HOLLERITH ! 132: C ! 133: HCOUNT = HCOUNT - 1 ! 134: KK = MAPCHR(CARD(I),ILHOL) ! 135: IF (HCOUNT.EQ.0) STATE = 0 ! 136: GO TO 290 ! 137: 210 NSTMT = NSTMT + 1 ! 138: STMT(NSTMT) = MAPCHR(CARD(I),ILLEG) ! 139: IF (STMT(NSTMT).NE.69) GO TO 220 ! 140: C ! 141: C BLANK ENCOUNTERED AND DELETED ! 142: C ! 143: BLK = BLK + 1 ! 144: NSTMT = NSTMT - 1 ! 145: GO TO 290 ! 146: 220 KK = STATE + 1 ! 147: GO TO (280, 260, 230), KK ! 148: C ! 149: C STATE 2--SKIP OVER LEADING DIGIT STRING; LOOK FOR H ! 150: C ! 151: 230 IF (STMT(NSTMT).LE.9) GO TO 290 ! 152: IF (STMT(NSTMT).NE.37) GO TO 270 ! 153: C ! 154: C PROCESS HOLLERITH COUNT ! 155: C ! 156: STMT(NSTMT) = -STMT(NSTMT) ! 157: STATE = 3 ! 158: KK = NSTMT - KST ! 159: I10 = 1 ! 160: HCOUNT = 0 ! 161: DO 240 K=1,KK ! 162: JJ = NSTMT - K ! 163: HCOUNT = HCOUNT + I10*STMT(JJ) ! 164: I10 = I10*10 ! 165: 240 CONTINUE ! 166: STMT(KST) = HCOUNT - 2048 ! 167: NSTMT = KST ! 168: IF (HCOUNT.LE.0) GO TO 250 ! 169: GO TO 290 ! 170: C ! 171: C AVOID THE 0H CONSTRUCTION ! 172: C ! 173: 250 CALL ERROR1(44H WARNING - 0H ILLEGAL HOLLERITH CONSTRUCTION, 44) ! 174: STATE = 0 ! 175: GO TO 290 ! 176: C ! 177: C STATE 1--LOOK FOR START OF DIGIT STRING BEFORE H ! 178: C ! 179: 260 IF (STMT(NSTMT).GT.9) GO TO 270 ! 180: STATE = 2 ! 181: KST = NSTMT ! 182: GO TO 290 ! 183: C ! 184: C CHECK FOR NESTED SPECIAL HEADING CHARS ! 185: C ! 186: 270 STATE = 0 ! 187: 280 IF ((STMT(NSTMT).LT.65) .OR. (STMT(NSTMT).GT.68)) GO TO 290 ! 188: STATE = 1 ! 189: 290 I = I + 1 ! 190: GO TO 180 ! 191: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.