SUBROUTINE ERROR(MESSAG, STATUS) C************************************************************ C C THIS SUBROUTINE IS USED TO PRINT ERROR MESSAGES C DURING THE EXECUTION OF "GIDUS" AND "DISLIB". THE C ERROR MESSAGES ARE PRINTED ON THE GT40 (PRECEEDED BY C A BELL IF FATAL) AND ARE ALSO WRITTEN IN THE LOG FILE C "DISLIB.LOG", IF LOGGING IS ENABLED. C C NOTE THAT "177 IS A NON-PRINTING FILLER CHARACTER C C POSSIBLE ERRORS: C NONE C C ROUTINES CALLED: C SFIELD - GENERAL BYTE STORAGE ROUTINE C GFIELD - GENERAL BYTE RETREIVAL ROUTINE C SNDCHR - SENDS AN IMAGE CHARACTER TO THE GT40 C C************************************************************ IMPLICIT INTEGER (A - Z) LOGICAL LOG INTEGER MESSAG(12), STRING(60) COMMON /LOGBLK/ LOG, GTLOG, FATAL, WARN DATA GT40 /5/ 1 FORMAT(1X,60A1,' "',O3,2X,I6) 2 FORMAT(60A1,' "',O3,2X,I6) 3 FORMAT(1X,60A1) 4 FORMAT(60A1) C CONVERT MESSAG FROM A5 FORMAT TO A1 FORMAT, STORE IN STRING DO 100 I = 1,60 CALL SFIELD(STRING(I), 0, 7, "177) 100 CONTINUE J = 0 DO 200 I = 1,60 WORD = I / 5 + (MOD(I,5) .EQ. 0) + 1 POS = MOD(I,5) + 5 * (MOD(I,5) .EQ. 0) * (-1) CHAR = GFIELD(MESSAG(WORD), (POS - 1) * 7, 7) IF(CHAR .EQ. 0) GO TO 300 CALL SFIELD(STRING(I), 0, 7, CHAR) J = I 200 CONTINUE C OVER-WRITE TRAILING SPACES WITH FILLER 300 DO 400 I = J,1,-1 IF(GFIELD(STRING(I), 0, 7) .NE. "40) GO TO 500 CALL SFIELD(STRING(I), 0, 7, "177) 400 CONTINUE 500 IF(GFIELD(STRING(1), 0, 7) .EQ. "77) CALL SNDCHR(7) IF(STATUS .EQ. 0) GO TO 600 WRITE(GT40, 1) STRING, STATUS, STATUS IF(LOG) WRITE(GTLOG, 2) STRING, STATUS, STATUS GO TO 700 600 WRITE(GT40, 3) STRING IF(LOG) WRITE(GTLOG, 4) STRING C UPDATE THE ERROR COUNTS 700 IF(GFIELD(STRING(1), 0, 7) .EQ. "77) FATAL = FATAL + 1 IF(GFIELD(STRING(1), 0, 7) .EQ. "45) WARN = WARN + 1 RETURN END