Return to FORMAT.f CVS log

Up to [Research Unix] / researchv10no / cmd / pfort

researchv10 Norman

      SUBROUTINE FORMAT
      INTEGER STMT, PSTMT
      LOGICAL TOKPNO, SIGN, ERROR
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C     ROUTINE PROCESSES FORMAT STMT
C     FORMAT (Q1 T1 Z1 T2 Z2 ... TN Q2)
C     Q1,Q2 ARE EMPTY OR ARE SEPARARTERS
C     T1,T2 ETC. ARE FORMAT-ITEMS
C     Z1,Z2, ETC. ARE SEPARATERS
C     CHECKS FOR <= 2 LEVELS OF PARENTHESES
C
      ERROR = .FALSE.
      ICNT = 0
C
C     "("
C
      IF (STMT(PSTMT).EQ.65) GO TO 30
   10 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
C
C     SEARCH FOR FORMAT ITEMS
C
   20 RETURN
   30 ICNT = ICNT + 1
      IF (ICNT.GT.2) CALL ERROR1(28H TOO MANY PARENTHESES LEVELS, 28)
      PSTMT = PSTMT + 1
C
C     LOOK FOR Q1
C
      CALL SEPAR(I)
C     TAKES CARE OF FORMAT()
      IF (STMT(PSTMT).EQ.62) GO TO 180
      IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION  (, ,
     *    25)
   40 IF (STMT(PSTMT).EQ.65) GO TO 30
      IF (PSTMT.GE.NSTMT) GO TO 10
      SIGN = .FALSE.
C
C     SEARCH FOR REPEAT FACTER (POSITIVE INTEGER)
C
      IF (TOKPNO(PSTMT,K2,N)) GO TO 70
C
C     HOLLERITH STRINGS
C
      IF (STMT(PSTMT).LT.0) GO TO 120
C
C     "-"       IN P SCALING FORMAT-ITEM
C
      IF (STMT(PSTMT).NE.61) GO TO 50
      SIGN = .TRUE.
      PSTMT = PSTMT + 1
   50 IF (PSTMT.GE.NSTMT) GO TO 10
C
C     LOOK FOR <INT> IN PSCALING FORMAT-ITEM
C     P SCALING FORMAT-ITEM
C     ( -       ) <INTEGER> P REPEAT (A,I,L) <WIDTH> . <INT>
C
      CALL NEXTOK(PSTMT, K2, K)
C
C     CHECK FOR USE OF "-" WITH NON P-SCALING CONSTRUCTS
C
      IF (K.NE.1 .AND. SIGN) GO TO 100
      IF (K.EQ.1) GO TO 60
      N = STMT(PSTMT)
      GO TO 90
   60 SIGN = .TRUE.
      PSTMT = K2
      N = STMT(PSTMT)
      GO TO 80
C
C     LOOK FOR PART OF FORMAT-ITEM AFTER REPEAT FACTOR
C
   70 PSTMT = K2
      N = STMT(PSTMT)
C
C     "("
C
      IF (N.EQ.65) GO TO 30
C
C     "X"
C
      IF (N.EQ.53) GO TO 120
C
C     "P"
C
   80 IF (N.EQ.45) GO TO 130
      IF (SIGN) GO TO 100
C
C     A,I,L
C
   90 IF (N.EQ.30 .OR. N.EQ.38 .OR. N.EQ.41) GO TO 110
C
C     D,E,F,G
C
      IF (N.GE.33 .AND. N.LE.36) GO TO 150
  100 CALL ERROR1(20H ILLEGAL FORMAT ITEM, 20)
      GO TO 20
C
C     A,I,L FOUND. LOOK FOR <WIDTH>
C
  110 IF (PSTMT+1.GE.NSTMT) GO TO 10
      PSTMT = PSTMT + 1
      IF (.NOT.TOKPNO(PSTMT,K2,I)) GO TO 100
      IF (N.NE.30 .OR. I.EQ.1 .OR. ERROR) GO TO 160
      CALL ERROR1(48H WARNING - A FORMAT ITEM NOT PORTABLE FOR N.GT.1,
     *    48)
      ERROR = .TRUE.
      GO TO 160
C
C     SKIP TO NEXT CHAR IN X OR HOLLERITH
C
  120 PSTMT = PSTMT + 1
      GO TO 170
C
C     LOOK FOR CONSTRUCT FOLLOWING THE P. CAN BE A REPEAT
C
  130 IF (PSTMT+1.GE.NSTMT) GO TO 10
      PSTMT = PSTMT + 1
      IF (STMT(PSTMT).GT.9 .OR. STMT(PSTMT).LT.0) GO TO 140
      CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.1) GO TO 10
      PSTMT = K2
C
C     AFTER D,E,F,G FIND <WIDTH> . <INT>
C
  140 IF (STMT(PSTMT).LT.33 .OR. STMT(PSTMT).GT.36) GO TO 10
  150 IF (PSTMT+1.GE.NSTMT) GO TO 10
      PSTMT = PSTMT + 1
      IF (.NOT.TOKPNO(PSTMT,K2,N)) GO TO 100
      IF (STMT(K2).NE.64) GO TO 100
      IF (K2+1.GE.NSTMT) GO TO 10
      PSTMT = K2 + 1
      CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.1) GO TO 100
  160 PSTMT = K2
C
C     FINISHED A FORMAT-ITEM
C     LOOK FOR SEPARATER OR ")"
C
  170 IF (STMT(PSTMT).NE.62) GO TO 210
  180 ICNT = ICNT - 1
      IF (ICNT.LT.0) GO TO 190
      IF (PSTMT+1.LT.NSTMT) GO TO 200
      IF (ICNT.EQ.0) GO TO 20
  190 CALL ERROR1(28H ILLEGAL PARENTHESES NESTING, 28)
      GO TO 20
  200 PSTMT = PSTMT + 1
      GO TO 170
  210 CALL SEPAR(I)
      IF (I.EQ.0) CALL ERROR1(24H MISSING FIELD SEPARATOR, 24)
      IF (STMT(PSTMT).NE.62) GO TO 40
      IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION  ,) ,
     *    25)
      GO TO 180
      END

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.