4      SUBROUTINE ERRMES(ERRFIL,ROUTIN,ERRNUM,ACTION)3C_TITLE  ERRMES  Error handling routine for TAPEIO.C0C_ARGS   TYPE        VARIABLE   I/O  DESCRIPTIONJC-------------------------------------------------------------------------O      CHARACTER*(*)  ERRFIL    !I    A string or variable at least 6 charactersKC                                    in length.  This variable shall be theKC                                    name of the error message file for theLC                                    calling routine.  There are a number ofLC                                    ways that the error message file can beJC                                    provided. 1) Complete name (example: IC                                    ERRFIL='DRA0:[EELIASON]TAPEIO.MSG').OC                                    A complete name shall consist of a device,NC                                    directory, name of file, and, file type).NC                                    2) Name shall be specified by letting theLC                                    device, directory and file type defaultHC                                    (example: ERRFIL='TAPEIO').  In theMC                                    default case, file type shall default toMC                                    '.MSG'.  If device and directory are notMC                                    provided, ERRMES shall first look in theMC                                    default directory for the file.  If noneMC                                    is found,  ERRMES shall then look at theJC                                    device and directory specified by theLC                                    logical name RAD$EXE (RAD$EXE points toFC                                    RADDSK:[RAD.EXE] directory unlessKC                                    optionally reassigned by the user). IfJC                                    an error message file is not found anEC                                    error message shall be output to0C                                    SYS$OUTPUT.P      CHARACTER*(*)  ROUTIN    !I    A string or variable at least 6 characters KC                                    in length.  This variable shall be theIC                                    name of the routine which has calledGC                                    ERRMES.  When looking for an errorLC                                    message, ERRMES shall match the routineMC                                    name with the routine names in the error2C                                    message file.O      INTEGER*4      ERRNUM    !I    The error number. ERRMES shall matche bothMC                                    the routine name and the error number inJC                                    the error message file to extract theBC                                    corrresponding error message.L      CHARACTER*(*)  ACTION    !I    A character string or variable at leastMC                                    two characters in length.  This variableLC                                    specifies the action to be performed byLC                                    ERRMES after writing the error message.DC                                    There shall be two options.  IfMC                                    ACTION='CO', then ERRMES shall return toJC                                    the calling program.  If ACTION='AB',LC                                    then ERRMES shall force the terminationMC                                    of the process and return a severe errorHC                                    code of SS$_FORCEXIT to the system.MC                                    ERRMES shall assume ACTION = 'AB' if the7C                                    string is invalid.CKC_DESC  ERRMES shall be designed to standardize error handling performed inFC       application programs.  ERRMES shall be similar to the RSX-11M LC       subroutine with the same name and function.  ERRMES shall be called KC       whenever a program needs to send an error message to the SYS$OUTPUTKC       file.  (SYS$OUTPUT is pointed to the terminal device in interactiveEC       jobs and the batch print file in batch jobs.  The pointing of=C       SYS$OUTPUT is performed automatically by the system.)LC       In order to use ERRMES, the programmer shall need to create an error*C       message file to be read by ERRMES.C9C_FILE: name                logical  access/  description+C                            unit    statusFC---------------------------------------------------------------------EC       DEFAULTFILE          IU1     READ     The error message file.CC                                             Three fields shall beCC                                             required in the file:DC                                             1) a 6-character fieldDC                                             containing the routineDC                                             name (left justified),DC                                             2) a 3-character fieldIC                                             containing the error numberDC                                             (right justified) and,BC                                             3) a variable lengthHC                                             character field containingHC                                             the message string for theGC                                             corresponding routine andLC                                             error number (left justified).IC                                             If the error message is tooKC                                             long to fit on one line, thenJC                                             it shall be continued on theHC                                             next line, leaving columnsIC                                             1-6 blank.  Any line with aFC                                             '*' in column 1 shall be@C                                             ignored by ERRMES.BC       SCREEN               IU1     WRITE    The terminal screen.+C                                    OPENEDCEC_HIST  07May85  Eric M. Eliason  U.S.G.S. Flagstaff Original VersionFC       21Nov86  Joni L. Bauers   updated documentation               7C       24Apr89  Debbie A. Cook   Updated documentation:C                                                         C_ENDOC******************************************************************************      CHARACTER*100 STRING      CHARACTER*120 ERR,ERR2      CHARACTER*8 ROUT      CHARACTER*1 LEVEL      LOGICAL*1 LXIST      DATA IU1,IU2/50,6/"      IF (ERRNUM.GT.999) GOTO 9070"      IF (ERRNUM.LT.0)   GOTO 9070OC******************************************************************************BC Use the INQUIRE statement to determine if the file name given toBC ERRMES exists. First look in the users default directory for the>C file name (using a default file type of '.MSG'). If the fileGC exists then use it, If the file does not exist in the current default@C directory, then look for the file in RAD$EXE directory. Again,BC the program assumes '.MSG' is the default file type. If the fileHC does not exist in either area, then write an error message and end jobOC******************************************************************************C      INQUIRE (FILE=ERRFIL,DEFAULTFILE='.MSG',EXIST=LXIST,ERR=9010)      IF (LXIST) GOTO 100B      INQUIRE (FILE=ERRFIL,DEFAULTFILE='RAD$EXE:.MSG',EXIST=LXIST,     .         ERR=9020)$      IF (.NOT.LXIST) GOTO 9060           GOTO 200MC****************************************************************************AC Program branches here when the file exists in the users default0C directory. Simply OPEN the file and branch outMC****************************************************************************  100 CONTINUE=      OPEN (UNIT=IU1,FILE=ERRFIL,DEFAULTFILE='.MSG',ERR=9030,'     .      STATUS='OLD',READONLY)           GOTO 300MC****************************************************************************CC Program branches here when the file exists in the RAD$EXE default0C directory. Simply OPEN the file and branch outLC***************************************************************************  200 CONTINUEE      OPEN (UNIT=IU1,FILE=ERRFIL,DEFAULTFILE='RAD$EXE:.MSG',ERR=9040,"     .      STATUS='OLD',READONLY)      GOTO 300LC***************************************************************************CC Next, start reading the input file. Search for a record which hasHC a routine name which matches with 'ROUTIN' and an error message numberEC which matches 'ERRNUM'. If no match is found write an error messageC indicating no match found.LC***************************************************************************  300 CONTINUE      STRING = ' 'B      READ(IU1,900,END=350,ERR=9050) ISLEN,(STRING(I:I),I=1,ISLEN)  900 FORMAT(Q,100A1)&      IF (STRING(1:1).EQ.'*') GOTO 300      ERR = ' ')      DECODE(100,905,STRING) ROUT,NUM,ERR  905 FORMAT(A6,I3,A91)      ILEN = 91      DO 305 I = 1,91)      IF (ERR(ILEN:ILEN).NE.' ') GOTO 306      ILEN = ILEN - 1  305 CONTINUE  306 CONTINUE"      IF (ROUT.NE.ROUTIN) GOTO 300!      IF (NUM.NE.ERRNUM) GOTO 300MC****************************************************************************EC An error number match found of error file. Before writing the error;C see if the next record is a continuation of error messageMC****************************************************************************      STRING = ' 'B      READ(IU1,900,END=320,ERR=9050) ISLEN,(STRING(I:I),I=1,ISLEN)&      IF (STRING(1:1).EQ.'*') GOTO 300*      DECODE(100,905,STRING) ROUT,NUM,ERR2      ILEN2 = 91      DO 311 I = 1,91,      IF (ERR2(ILEN2:ILEN2).NE.' ') GOTO 312      ILEN2 = ILEN2 - 1  311 CONTINUE  312 CONTINUE      IF (ROUT.EQ.' ') THEN#            ERR = ERR(1:ILEN)//ERR2            ILEN = ILEN + ILEN2'            IF (ILEN.GT.120) ILEN = 120      END IF      GOTO 320MC****************************************************************************GC Program branches here when an error number and routine name not foundCC in the error message file. Generate an error message and continueC with the taskMC****************************************************************************  350 CONTINUEA      ERR = 'No error message found for error number and routine'      ILEN = 54      GOTO 320MC****************************************************************************?C Now write the error, see if I am supposed to abort the job or$C return for continuation of the jobLC***************************************************************************  320 CONTINUE      LEVEL = 'F'%      IF (ACTION.EQ.'CO') LEVEL = 'I'<      WRITE(IU2,920) LEVEL,ROUTIN,ERRNUM,(ERR(I:I),I=1,ILEN)=  920 FORMAT(' %ERRMES-',A1,'-',A6,'(',I3,'), ',100A1,/,20a1)      CLOSE (UNIT=IU1)7      ISTAT = 8572 !error code SS$_FORCEXIT, (HEX 217C)+  325 IF (ACTION.NE.'CO')  CALL EXIT(ISTAT)      RETURNJC*************************************************************************C Can not open SYS$OUTPUT fileJC************************************************************************* 9005 CONTINUE      ACTION = 'AB'      GOTO  325MC****************************************************************************-C Can not inquire into status of messge filesMC**************************************************************************** 9010 CONTINUE 9020 CONTINUEF      ERR = 'ERRMES can not service error message request from caller'      ILEN = 56      ERRNUM = -1      GOTO 320NC*****************************************************************************C Can not open message file NC***************************************************************************** 9030 CONTINUE 9040 CONTINUE:      ERR = 'ERRMES can not open error file to process '//     .'error message request'      ILEN = 64      ERRNUM = -1      GOTO 320MC****************************************************************************'C Can not read a record from error fileMC**************************************************************************** 9050 CONTINUEF      ERR = 'ERRMES i/o error while trying to read error message file'      ILEN = 56      ERRNUM = -1      GOTO 320LC***************************************************************************+C ERRMES can not find an error message fileKC************************************************************************** 9060 CONTINUE9      ERR='ERRMES unable to find error file in DEFAULT'//-     .' or RAD$EXE directory, File: '//ERRFIL      ILEN = 90      ERRNUM = -1      GOTO 320IC************************************************************************C ERRNUM outside range 0 to 999GC********************************************************************** 9070 CONTINUEA      ERR='ERRNUM outside range 0 to 999, no message generated  '      ILEN = 53      ERRNUM = -1      GOTO 320	      END