Return to ERROR2.f CVS log

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

researchv10 Norman

      SUBROUTINE ERROR2( I,  JJ, K, NN, SPBEF, SPAFT )
C
C     PRINTS ERROR MESSAGES AND SYMBOLIC NAME
C     I IS PACKED HOLLERITH STRING
C     JJ IS NUMBER OF CHARACTERS TO BE PRINTED ( N = JJ)
C     K CONTAINS INTEGER OR HOLLERITH INFO TO FOLLOW MESSAGE
C     NN CONTROLS TYPE OF LINE TO BE PRINTED
C
C     NN = 0 MEANS PRINT MESSAGE
C
C     NN < 0 MEANS IF JJ=0 NO MESSAGE, ELSE PRINT MESSAGE
C     ON NEXT LINE IF NN = -1 PRINT PGM UNIT AND/OR STMT NO
C     (CONTROLLED BY CONTENTS OF K).
C     ON NEXT LINE IF NN = -2 PRINT PARAMETER NUMBER IN K
C     NN = -3 USED FOR SPACING CONTROL IN LONG MESSAGES
C
C     NN > 0 MEANS PRINT MESSAGE FOLLOWED BY IDENTIFIER IN K
C     SPBEF, SPAFT CONTROL LINE SPACING BEFORE AND AFTER MESSAGE
C     IF = 1, BLANK LINE EMMITTED
C
      INTEGER I(1), J(80), OUTUT, PDSA, DSA, M(6), K(6), W
      INTEGER SPBEF, SPAFT
      LOGICAL OPT, P1ERR, P2, QBR
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, I1, I2, I3, I4
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /OPTNS/ OPT(5), P1ERR
      COMMON /PASS/ P2, QBR
      DATA W /1HW/, KK /1H-/
C
C     ERROR IN P.U. DURING PROCESSING OF A HEADING STMT, SPECIFI STMT,
C     EQUIV STMT, OR DATA STMT CAUSES PASS 2 TO BE SUPPRESSED FOR THAT
C     P.U.
C
      IF (QBR) GOTO 45
      IF(SPBEF.EQ.1) WRITE(OUTUT, 99998)
      N = JJ
      IF (N.GT.72) N = 72
      J(2) = KK
      IF (N.GE.1) CALL S5UNPK(I, J, N)
      IF (ITYP.LT.14 .AND. J(2).NE.W) P1ERR = .TRUE.
      IF (NN) 50, 10, 30
C
C     NN=0
C
   10 CONTINUE
      WRITE (OUTUT,99997) (J(L),L=1,N)
      IF(P2 .OR. OPT(4)) GOTO 40
      CALL S5UNPK(DSA(NAME+4), J(1), 6)
      WRITE (OUTUT,99999) NOST, (J(L),L=1,6)
99999 FORMAT (16H *** AT STMT NO , I6, 13H IN PGM UNIT , 6A1)
99998 FORMAT(1H )
      GO TO 40
C
C     NN>0
C
   30 CONTINUE
      IF (N.GT.68) N = 68
      CALL S5UNPK(K, J(73), 6)
      WRITE (OUTUT,99997) (J(L),L=1,N), KK, KK, (J(L),L=73,78)
99997 FORMAT (4H ***, 76A1)
 40   IF(SPAFT.EQ.1) WRITE(OUTUT, 99998)
 45   RETURN
C
C     NN<0
C
   50 CONTINUE
      IF (N.GE.1) WRITE (OUTUT,99997) (J(L),L=1,N)
      IF( -2.EQ.NN ) GOTO 70
      IF( -3.EQ.NN ) GOTO 40
      CALL S5UNPK(DSA(NAME+4), M(1), 6)
C     WRITE OUT STMT NO AND/OR PGM UNIT
      IF (K(1).EQ.0) GO TO 60
      WRITE (OUTUT,99996) K(1), (M(L),L=1,6)
99996 FORMAT (16H *** AT STMT NO , I6, 1X, 13H IN PGM UNIT , 6A1)
      GO TO 40
   60 WRITE (OUTUT,99995) (M(L),L=1,6)
99995 FORMAT (17H *** IN PGM UNIT , 6A1)
      GO TO 40
C     WRITE OUT PARAMETER NO FOR PARAMETERLIST ERRORS
 70   WRITE(OUTUT,99994) K(1)
99994 FORMAT(22H *** PARAMETER NUMBER ,I6)
      GOTO 40
      END

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