C ERROR REPORTING SUBROUTINE. C C Submitted by: C C R. N. Stillwell C Institute for Lipid Research C Baylor College of Medicine C Houston, Texas 77030 C C (who would be glad to receive comments, suggestions, bug fixes, etc., but C who promises no support whatever). C C Literature reference: C C R. N. Stillwell. A low-overhead laboratory data management system C for the PDP11. Comput. Biomed. Res., 15, 29-38(1982). C C Acknowledgement: C C This software was developed under National Institutes of Health grants C GM-13901 and GM-26611. C C General permission is hereby granted to copy, modify, or distribute this C program, but not for profit. Copyright to this software is and shall C remain in the public domain. C C ARGUMENTS ARE: C IERROR INTEGER ERROR CODE (SEE SELECT(IERROR)) C LNAME INTEGER USUALLY, LENGTH OF NAME C NAME BYTE ARR. STUFF TO PRINT C SUBROUTINE ERROR (IERROR,LNAME,NAME) C INTEGER IERROR, LNAME BYTE NAME(1) BYTE NAME2(6) C C DECLARE COMMON BLOCKS C COMMON /TABDAT/ NREC,NCOLS,LENREC,IOFSET,IPTRD,TABREC, 1 DATA INTEGER NREC,NCOLS,LENREC,IOFSET,IPTRD(41),TABREC BYTE DATA(1000) COMMON /LUN/ INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN INTEGER INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN COMMON /INPUT/ IREC,INPTR,LLINE,INLINE BYTE INLINE(132) DATA MAXIN/132/ COMMON /OUTPUT/ OUTLIN,OUTPTR,OUTEND BYTE OUTLIN (132) INTEGER OUTPTR,OUTEND DATA MAXOUT /132/ COMMON /FILES/ FILNAM,MAXFNM,MODNAM,LFNAM,FLREC, 1 MAXLVL,INLVL,OLDLVL,ULBUF,CARCTL,TERM 1 ,OUTOPN,TBOPEN C C FILE STACK C BYTE FILNAM(26,5) DATA MAXFNM/26/ REAL*4 MODNAM(5) !9-OCT-81 RAD50 MODULE NAMES INTEGER LFNAM(5) !LENGTHS OF NAMES C !POINTERS TO START OF CURRENT C !OR NEXT RECORD REAL*4 FLREC(5) !9-OCT-81 CHANGED FROM C !RECORD PTR TO BYTE PTR C D INTEGER IFLREC(2,5) D EQUIVALENCE (IFLREC,FLREC) DATA MAXLVL/5/ INTEGER INLVL !CURRENT LEVEL POINTER INTEGER OLDLVL !PREVIOUS LEVEL POINTER INTEGER ULBUF (7) BYTE CARCTL LOGICAL*1 TERM,OUTOPN,TBOPEN C C SCRATCH MEMORY. DEFINITIONS MAY DIFFER FROM SUBROUTINE TO SUBROUTINE, C OR MAY USE EQUIVALENCE STATEMENTS. C COMMON /SCRATCH/ SCRATCH BYTE SCRATCH (576) C C LOCAL DECLARATIONS C SELECT (IERROR) (1) ABORT-ON-IF-ERROR (2) ABORT-ON-FILE-ERROR (3) ABORT-ON-INPUT-FILE-ERROR (4) ABORT-ON-INPUT-STACK-OVERFLOW (5) ABORT-ON-LABEL-NOT-FOUND (6) ABORT-ON-OUTPUT-FILE-ERROR (7) ABORT-ON-TABLE-NAME-ERROR (8) ABORT-ON-WHILE-MATCH-ERROR (9) ABORT-ON-WHILE-STACK-ERROR (101) REPORT-ERROR-LINE (102) REPORT-EVALUATION-ERROR (103) REPORT-FILE-NAME (104) REPORT-ILLEGAL-COMMAND (105) REPORT-INVALID-FORMAT (106) REPORT-SKIP-ERROR (107) REPORT-VARIABLE-ERROR (108) REPORT-ADDVAR-ERROR (OTHERWISE) REPORT-UNKNOWN-ERROR FIN RETURN TO ABORT-ON-IF-ERROR WRITE (TILUN,49) 49 FORMAT (' Unbalanced %IF - %EIF commands') REPORT-ERROR-LINE STOP FIN TO ABORT-ON-FILE-ERROR REPORT-ERROR-LINE STOP FIN TO ABORT-ON-INPUT-FILE-ERROR WRITE (TILUN,402) (FILNAM(I,INLVL),I=1,LFNAM(INLVL)) 402 FORMAT (' Cannot read file',(,40A1)) INLVL = INLVL-1 ABORT-ON-FILE-ERROR FIN TO ABORT-ON-INPUT-STACK-OVERFLOW WRITE (TILUN,41) MAXLVL 41 FORMAT (' Maximum input level (=',I2,') exceeded.') REPORT-ERROR-LINE WRITE (TILUN,4100) DO (J=1,MAXLVL) WRITE (TILUN,410) (FILNAM(I,J),I=1,LFNAM(J)) 4100 FORMAT (' Files are:') 410 FORMAT (1X,40A1) STOP FIN TO ABORT-ON-LABEL-NOT-FOUND WRITE (5,44) (NAME(I),I=1,LNAME) 44 FORMAT ('$Label "',40A1) WRITE (5,45) 45 FORMAT ('+','"'/' not found.') REPORT-FILE-NAME STOP FIN TO ABORT-ON-OUTPUT-FILE-ERROR WRITE (TILUN,4020) 4020 FORMAT (' Cannot open output file') ABORT-ON-FILE-ERROR FIN TO ABORT-ON-TABLE-NAME-ERROR WRITE (TILUN,404) (NAME(I),I=1,LNAME) 404 FORMAT (' Cannot open table',(1X,40A1)) ABORT-ON-FILE-ERROR FIN TO ABORT-ON-WHILE-MATCH-ERROR WRITE (TILUN,4041) 4041 FORMAT (' Unbalanced %WHILE - %EWHILE commands') ABORT-ON-FILE-ERROR FIN TO ABORT-ON-WHILE-STACK-ERROR C EQUIVALENCE (MAXWHL,LNAME) WRITE (TILUN,4042) LNAME 4042 FORMAT (' Maximum WHILE-level (',i2,') exceeded') ABORT-ON-FILE-ERROR FIN TO REPORT-ERROR-LINE WRITE (TILUN,30) (INLINE(J),J=1,LLINE) 30 FORMAT (' at "X" in the following line:'/1X,132A1) DO (I=1,MAXIN) INLINE(I) = ' ' L = INPTR IF (L.EQ.0) L = LLINE INLINE(L) = 'X' WRITE (TILUN,31) (INLINE(J),J=1,L) 31 FORMAT (1X,132A1) REPORT-FILE-NAME C IGNORE REST OF LINE INPTR = 0 !FLUSH-INPUT FIN TO REPORT-EVALUATION-ERROR C MESSAGE SHOULD ALREADY HAVE BEEN WRITTEN REPORT-ERROR-LINE FIN TO REPORT-FILE-NAME WRITE (TILUN,43) INLVL,(FILNAM(J,INLVL),J=1,LFNAM(INLVL)) 43 FORMAT (' in file at level',I4,': ',40A1) IF (MODNAM(INLVL).NE.0.0) TYPE-CURRENT-MODULE-NAME WRITE (TILUN,4301) 4301 FORMAT (1X) FIN TO REPORT-ILLEGAL-COMMAND WRITE (TILUN,401) 401 FORMAT (' Illegal command.') REPORT-ERROR-LINE FIN TO REPORT-INVALID-FORMAT WRITE (TILUN,411) (NAME(I),I=1,LNAME) 411 FORMAT (' Invalid format:',(1X,80A1)) REPORT-ERROR-LINE FIN TO REPORT-SKIP-ERROR WRITE (TILUN,412) OUTPTR 412 FORMAT (' Invalid skip value: ',I6) REPORT-ERROR-LINE FIN TO REPORT-VARIABLE-ERROR C EQUIVALENCE (LENVAR,LNAME),(VARNAM,NAME) SELECT (LNAME) (-1) WRITE (TILUN,46) (NAME(I),I=1,8) (-2) WRITE (TILUN,47) (NAME(I),I=1,8) (OTHERWISE) WRITE (TILUN,48) LNAME,(NAME(I),I=1,8) FIN 46 FORMAT (' Invalid call to GETVAR for variable ',8A1) 47 FORMAT (' No such variable as ',8A1) 48 FORMAT (' Unknown error return (',I4,') for variable ',8A1) REPORT-ERROR-LINE FIN TO REPORT-ADDVAR-ERROR SELECT (LNAME) (-3) WRITE (5,61) (NAME(I),I=1,8) (-2) WRITE (5,62) (NAME(I),I=1,8) (-1) WRITE (5,63) (NAME(I),I=1,8) FIN 61 FORMAT (' No room in variable index for ',8A1) 62 FORMAT (' No room in variable storage area for ',8A1) 63 FORMAT (' Variable ',8A1,' has length < 0.') FIN TO REPORT-UNKNOWN-ERROR WRITE (TILUN,500) IERROR 500 FORMAT (' UNKNOWN ERROR, ',I8) REPORT-ERROR-LINE FIN TO TYPE-CURRENT-MODULE-NAME CALL R50ASC(6,MODNAM(INLVL),NAME2) WRITE (TILUN,513) (NAME2(I),I=1,6) 513 FORMAT (' in module: ',6A1) FIN END