FTN4 PROGRAM DCRCV(4,90), 92080-16584 REV. 2026 800513 C C C SOURCE : &DCRCV 92080-18584 C RELOC. : %DCRCV 92080-16584 C C C PGMR: STEVE WITTEN, C DATA SYSTEMS DIVISION, C CUPERTINO, CALIFORNIA C C C C ************************************************************* C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-* C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************* C C IMPLICIT INTEGER (A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB,STRBF( *5) C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK,SRSTER C note: max screen size = 100 chrs. DIMENSION SCREEN(50) C note: main program booleans LOGICAL GETOK LOGICAL OPOK C note: boolean functions LOGICAL GETBK LOGICAL SNTX1 LOGICAL SNTX2 LOGICAL SNT36 LOGICAL SNTX4 LOGICAL SNT57 LOGICAL STRAP LOGICAL STRP C note: local data DATA KYSCNO/0/ DATA MNSCNO/1/ DATA ARSCNO/2/ DATA PUSCNO/3/ DATA COSCNO/4/ DATA PRSCNO/5/ DATA LSSCNO/6/ DATA LTSCNO/7/ C C begin main program -- get the terminal lu# and lock it C TERM = LOGLU(IX) CALL LURQ(LULCK,TERM,1) C set option equal to blank OPT = BLANK C provide return in case of abort ASSIGN 1 TO RTNPT C and user didn't really want to (yecch!) 1 STRP = STRAP(TERM,STRBF,0) C display the key map screen CALL RECSC(TERM,KYSCNO) IF(.NOT.(STRP))GOTO 23000 CALL RECOR(TERM,SRSTER,1) 23000 CONTINUE GETOK = .FALSE. CONTINUE 23002 IF(.NOT.(.NOT.GETOK))GOTO 23003 GETOK = .NOT.GETBK(TERM,SCREEN,SC0LN) GOTO 23002 23003 CONTINUE C ck for abort & do if necessary CALL RCKAB(SCREEN,SC0LN,SC0FLN) CONTINUE 23004 IF(.NOT. (OPT .NE. TERMNT))GOTO 23005 C provide return in case of abort ASSIGN 2 TO RTNPT C and user didn't really want to (yec C display the menu screen 2 CALL RECSC(TERM,MNSCNO) C get the screen data and do syntax c GETOK = .FALSE. OPOK = .TRUE. CONTINUE 23006 IF(.NOT. (.NOT.GETOK .OR. .NOT.OPOK))GOTO 23007 GETOK = .NOT.GETBK(TERM,SCREEN,SC1LN) OPOK = SNTX1(SCREEN) C C process archive option C GOTO 23006 23007 CONTINUE IF(.NOT. (OPT .EQ. ARCHIV))GOTO 23008 C assign return in case abort key ASSIGN 3 TO RTNPT C is pressed and user says no C (yecch!) C display archive screen 3 CALL RECSC (TERM,ARSCNO) GETOK = .FALSE. OPOK = .TRUE. C C get data and do syntax check C CONTINUE 23010 IF(.NOT. (.NOT.GETOK .OR. .NOT.OPOK))GOTO 23011 GETOK =.NOT.GETBK(TERM,SCREEN,SC2LN) OPOK = SNTX2(SCREEN) C C process the archive request C GOTO 23010 23011 CONTINUE CALL TPHND(COMP,FILE) C C process recovery option C 23008 CONTINUE IF(.NOT. (OPT .EQ. RECOVR))GOTO 23012 ASSIGN 4 TO RTNPT 4 CALL RECSC (TERM,COSCNO) GETOK = .FALSE. OPOK = .TRUE. CONTINUE 23014 IF(.NOT. (.NOT.GETOK .OR. .NOT.OPOK))GOTO 23015 GETOK = .NOT.GETBK(TERM,SCREEN,SC4LN) OPOK = SNTX4(SCREEN,RCTYP,FLTYP) GOTO 23014 23015 CONTINUE IF(.NOT. (RCTYP .EQ. COMP))GOTO 23016 CALL TPHND(RCTYP,FLTYP) 23016 CONTINUE IF(.NOT. (RCTYP .EQ. PART))GOTO 23018 ASSIGN 41 TO RTNPT 41 CALL RECSC(TERM,PRSCNO) GETOK = .FALSE. OPOK = .TRUE. CONTINUE 23020 IF(.NOT. (.NOT.GETOK .OR. .NOT.OPOK))GOTO 23021 GETOK = .NOT.GETBK(TERM,SCREEN,SC57LN) OPOK = SNT57(SCREEN,PRSCNO * ,RCTYP,YR1,DATE1,HR1,MIN1 * ,SEC1,MS1,YR2,DATE2, * HR2,MIN2,SEC2,MS2) GOTO 23020 23021 CONTINUE CALL TPHND(RCTYP,FLTYP,YR1 * ,DATE1,HR1,MIN1,SEC1,MS1,YR2 * ,DATE2,HR2,MIN2,SEC2,MS2) 23018 CONTINUE C C process purge option C 23012 CONTINUE IF(.NOT. (OPT .EQ. PRGE))GOTO 23022 C assign return point in case ASSIGN 5 TO RTNPT C is pressed and user says no C (yechh!!) 5 CALL RECSC (TERM,PUSCNO) GETOK = .FALSE. OPOK = .TRUE. C C get data and do syntax check C CONTINUE 23024 IF(.NOT. (.NOT.GETOK .OR. .NOT.OPOK))GOTO 23025 GETOK = .NOT.GETBK(TERM,SCREEN,SC36LN) OPOK = SNT36(SCREEN,FLTYP) C C process purge request C GOTO 23024 23025 CONTINUE CALL PURG(FLTYP) C C process list option C 23022 CONTINUE IF(.NOT. (OPT .EQ. LIST))GOTO 23026 LCKCHK = NO ASSIGN 6 TO RTNPT 6 CALL RECSC (TERM,LSSCNO) C C get screen data C GETOK = .FALSE. OPOK = .TRUE. CONTINUE 23028 IF(.NOT. (.NOT.GETOK .OR. .NOT.OPOK))GOTO 23029 GETOK = .NOT.GETBK(TERM,SCREEN,SC36LN) OPOK = SNT36(SCREEN,FLTYP) GOTO 23028 23029 CONTINUE ASSIGN 61 TO RTNPT 61 CALL RECSC(TERM,LTSCNO) GETOK = .FALSE. OPOK = .TRUE. CONTINUE 23030 IF(.NOT. (.NOT.GETOK .OR. .NOT.OPOK))GOTO 23031 GETOK = .NOT.GETBK(TERM,SCREEN,SC57LN) OPOK = SNT57(SCREEN,LTSCNO,LSTYP * ,YR1,DATE1,HR1,MN1,SC1 * ,MS1,YR2,DATE2,HR2,MN2 * ,SC2,MS2) C C got good screen data -- process log file for listing C GOTO 23030 23031 CONTINUE ASSIGN 6 TO RTNPT CALL TPHND(LSTYP,FLTYP,YR1,DATE1,HR1,MN1 * ,SC1,MS1,YR2,DATE2,HR2,MN2,SC2,MS2) 23026 CONTINUE GOTO 23004 23005 CONTINUE CALL LURQ(LUULK,TERM,1) CALL RCABT END C C intlz -- global data initialization C BLOCK DATA INTLZ, 92080-16584 REV. 2026 800508 C C IMPLICIT INTEGER (A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB,STRBF( *5) C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK,SRSTER C C global data initialization C C maximum lu# allowed DATA MAXLU/63/ C length of data from key map screen DATA SC0LN/2/ C length of data from menu screen DATA SC1LN/4/ C length of data from archive screen DATA SC2LN/23/ C length of data from purge/lstng#1 screen DATA SC36LN/23/ C length of data from complete recovery scr. DATA SC4LN/30/ C length of data from partial recov/lstng#2 scr. DATA SC57LN/47/ DATA ARCHIV /2H A/ DATA LIST /2H L/ DATA PRGE /2H P/ DATA RECOVR /2H R/ DATA TERMNT /2H T/ DATA COMP /2H C/ DATA PART /2H P/ DATA YES /2H Y/ DATA NO /2H N/ DATA BLANK /2H / C fmgr error code -- file does not exist DATA GONE /-6/ C fmgr error code -- file is open or locked DATA LOCKED /-8/ C mag tape driver type DATA MTDVNO/23B/ C max rec len of recovery record DATA MXRCLN/625/ DATA FILE/2HFL/ C recovery/list/purge file flag DATA UNIT/2HLU/ C recovery/list/purge LU flag C # chars in FMP error buffer DATA NOERCH/4/ C exec read request DATA RDRQ/1/ C exec write request DATA WRRQ/2/ C exec control request DATA CTLRQ/3/ DATA HEADR/2HHD/ C header record id DATA THRU /2H T/ DATA AFTER/2H A/ DATA INCL /2H I/ DATA NTINCL/2H N/ DATA SCCKWD/8/ DATA SGNBIT/15/ DATA RWND/400B/ DATA RWSTBY/500B/ DATA WREOF/100B/ DATA ERASE/1200B/ DATA RECRD/2HRC/ C data record id DATA TAPHN/2HTP/ DATA RCV/2HRV/ DATA LULCK/100001B/ DATA LUULK/0B/ DATA TMPTYP/45/ C C GLOBAL VARIABLE INITIALIZATIONS C DATA INDBNO/-1,0,0,0,0,0,0,0,0,0 ,-1,0,0,0,0,0,0,0,0,0 * ,-1,0,0,0,0,0,0,0,0,0 ,-1,0,0,0,0,0,0,0,0,0 * ,-1,0,0,0,0,0,0,0,0,0 ,-1,0,0,0,0,0,0,0,0,0 * ,-1,0,0,0,0,0,0,0,0,0 ,-1,0,0,0,0,0,0,0,0,0/ DATA NXTDB/1/ C C error code initializations C C an answer is expected DATA ANSEXP /1/ C illegal answer DATA ILLANS /2/ C field must be numeric DATA NUMFLD /3/ C illegal lu# DATA BADLU /4/ C illegal file name DATA BDFLNM /5/ C bad cr# DATA BDCRNO /6/ C bad security code DATA BDSC /7/ C namr not found DATA NOTFND /8/ C archive device not a mag-tape DATA ARDNMT /9/ C OPEN error DATA OPENER /10/ C cartrige not mounted DATA CRNMTD /11/ C wrong security code DATA WRNGSC /12/ C illegal list device DATA BDLST /13/ C namr is open or locked DATA FLLCKD /14/ C all namr fields must be blank DATA NOFLLU /15/ C PURGE error DATA PURGER /16/ C all time stamp fields must be blank DATA TMSTBK /17/ C no time stamp fields may be blank DATA NTSFBK /18/ C these time stamp fields must be blank DATA TTSFBK /19/ C incomplete time stamp given DATA INCTST /20/ C illegal date DATA DATERR /21/ C illegal hour DATA HRERR /22/ C illegal minute DATA MINERR /23/ C illegal second DATA SECERR /24/ C illegal msec DATA MSCERR /25/ C date#2 < date#1 DATA DT1DT2 /26/ C time#2 < time#1 DATA TM1TM2 /27/ C log file specified is not from TMP DATA NTDCP /28/ C this field must be blank DATA FLDBLK /29/ C terminal strap read error DATA SRSTER /30/ END C C wait -- wait for a time C SUBROUTINE WAIT(WTTIM) *, 92080-16584 REV. 2026 800213 IMPLICIT INTEGER(A-Z) DATA WAITRQ/12/ DATA SELF/0/ DATA RESCDE/2/ CALL EXEC(WAITRQ,SELF,RESCDE,SELF,-WTTIM) RETURN END C C rcabt -- dcrcv abort routine C SUBROUTINE RCABT, 92080-16584 REV. 2026 800508 IMPLICIT INTEGER (A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB,STRBF( *5) C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK,SRSTER LOGICAL RESET LOGICAL REST C local messages & data DIMENSION ENDMSG(12),OFBKMD(3) DIMENSION ENDMG2(7),DCMON(3),TRSTP(27) DATA ENDMSG/2H ,2H ,2H ,2H ,2H ,2H"D,2HCM,2HON,2H" ,2HGO,2HNE *,2H! / C end message DATA ENDMG2/2H/D,2HCR,2HCV,2H :,2H $,2HEN,2HD / DATA TRSTP/2H/D,2HCR,2HCV,2H: ,2HTe,2Hrm,2Hin,2Hal,2H s,2Htr,2Hap, *2H r,2Hes,2Het,2H e,2Hrr,2Hor,2H..,2H.s,2Htr,2Hap,2Hs ,2Hno,2Ht ,2 *Hre,2Hse,2Ht!/ DATA DCMON/2HDC,2HMO,2HN / C turn off block mode DATA OFBKMD/015446B,065460B,041000B/ C unlock keyboard DATA UNLKKB/015542B/ C len of blk md off message DATA OFBKLN/-5/ C len of unlock kbd message DATA UNLKLN/-2/ C CR LF DATA CRLF /006412B/ C format mode on DATA FMTON /015530B/ C home up the cursor DATA HOMEUP/015550B/ C clear the display DATA CLRDSP/015512B/ C unlock terminal memory DATA MEMULK/015555B/ C parameter for 'EXEC' to schedule DATA SCHDUL/100027B/ C 'DCMON' C parameter for 'EXEC' to stop DATA QUIT /6/ C length of end message DATA ENDLN /13/ DATA ENDLN2/7/ REST = RESET(TERM,STRBF,IER,0) CALL EXEC(SCHDUL,DCMON,TERM,1,0,0,0) GO TO 100 GO TO 101 100 CALL REIO(WRRQ,TERM,OFBKMD,OFBKLN) CALL REIO(WRRQ,TERM,ULKKB,UNLKLN) ENDMSG = CRLF ENDMSG(2) = FMTON ENDMSG(3) = MEMULK ENDMSG(4) = HOMEUP ENDMSG(5) = CLRDSP ENDMSG(13)= CRLF CALL REIO(WRRQ,TERM,ENDMSG,ENDLN) IF(.NOT.(REST))GOTO 23032 CALL REIO (WRRQ,TERM,TRSTP,27) 23032 CONTINUE CALL REIO(WRRQ,TERM,ENDMG2,ENDLN2) GO TO 103 101 CONTINUE IF(.NOT.(REST))GOTO 23034 CALL REIO(WRRQ,TERM,TRSTP,27) 23034 CONTINUE 103 CALL EXEC(QUIT) CALL CLOSE(DCB) END C C rckab -- check for abort C SUBROUTINE RCKAB(SCRDAT,SCRLN,FLDLN,FLDNO) *, 92080-16584 REV. 2026 800222 IMPLICIT INTEGER (A-Z) C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB,STRBF( *5) C screen buffer DIMENSION SCRDAT(1) C note: boolean variables LOGICAL ABOK LOGICAL ABFND C boolean functions LOGICAL JPAR LOGICAL OKABT LOGICAL GETBK DATA ABFLG /9/ IF(.NOT. (FLDNO .EQ. 0))GOTO 23036 C set default fld# to first fld FLDNO = 1 23036 CONTINUE C abort key pressed? ABFND = JPAR(SCRDAT,SCRLN,FLDNO,X,FLDLN,JFLAG,M) C make sure the user C really wants to abort IF(.NOT. (ABFND .AND. JFLAG .EQ. ABFLG))GOTO 23038 ABOK = OKABT(TERM) GOTO 23039 23038 CONTINUE RETURN 23039 CONTINUE IF(.NOT. (ABOK))GOTO 23040 C the user wants to abort -- do it CALL LURQ(LUULK,TERM,1) CALL RCABT GOTO 23041 23040 CONTINUE C go to return point provided in case GO TO RTNPT C of a 'no' answer (yecch!!) 23041 CONTINUE END C C okprg -- ask user if ok to purge C LOGICAL FUNCTION OKPRG(LU) *, 92080-16584 REV. 2026 800213 C ******************************** C * THIS FUNCTION PRINTS ON LU: * C * " O.K. TO PURGE? .. (Y/N) " * C * * C * FORTRAN CALL: * C * * C * --IF(OKPRG(LU)) GOTO "YES" * C * --GOTO "NO" * C ******************************** C C IMPLICIT INTEGER (A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP DIMENSION IMESA(29),IBLOK(3) DATA IMESA/15530B,15555B,15446B,2Hk0,2HB ,15510B,15512B * ,15542B,15446B,2HdB,2H O,2H.K,2H. ,2HTO ,2H P,2HUR,2 *HGE,2H ?,2H :,2H ,2H (,2HY/,2HN) ,20033B,2H&d,40033B,2 *H&a,2H-8,2HC_/ DATA IBLOK/15446B,2Hk1,2HB / DATA IMESLN/29/ DATA IBLKLN/3/ DATA ONECHR/1/ DATA CTRL/500B/ C OKPRG = .TRUE. CALL EXEC(WRRQ,LU,IMESA,IMESLN) CALL REIO(RDRQ,LU+CTRL,IZZ,-ONECHR) C C-----RESTORE BLOCK MODE C CALL EXEC(WRRQ,LU,IBLOK,IBLKLN) IF(.NOT.(IALF2(IGET1(IZZ,1)) .EQ. YES))GOTO 23042 RETURN 23042 CONTINUE OKPRG = .FALSE. RETURN END C C gdvtp -- get driver type of an lu C FUNCTION GDVTP(LUNUM) *, 92080-16584 REV. 2026 800213 IMPLICIT INTEGER (A-Z) DATA ISCNST/37400B/ DATA LSHFT /256/ DATA REQCD /13/ CALL EXEC(REQCD,LUNUM,IEQT5) GDVTP = IAND(IEQT5,ISCNST)/LSHFT RETURN END C C mthnd -- mag-tape handler C SUBROUTINE MTHND(TERM,MTLU,FNTN,ETFLG) *, 92080-16584 REV. 2026 800430 IMPLICIT INTEGER(A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP LOGICAL TAPEOK LOGICAL ETFLG DIMENSION TMLMEM(2) DATA MTSCNO/8/ DATA DOWN/1/ DATA WRTRNG/2/ DATA NTONLN/4/ DATA PARITY/3/ DATA LCKED/5/ DATA LCKLN/4/ DATA TMLMEM/015555B,015554B/ TAPEOK = .FALSE. CONTINUE 23044 IF(.NOT. (.NOT.TAPEOK))GOTO 23045 CALL RECSC(TERM,MTSCNO) IZ = 0 CALL REIO(RDRQ,TERM,IZ,-1) IF(.NOT.(.NOT.ETFLG))GOTO 23046 CALL RCKAB(IZ,1,1,1,1) 23046 CONTINUE CALL CHKMT(MTLU,ISTAT) IF(.NOT. (ISTAT .EQ. DOWN))GOTO 23048 CALL MTERR(TERM,MTLU,DOWN) CALL WAIT(5) 23048 CONTINUE IF(.NOT. (ISTAT .EQ. WRTRNG .AND. FNTN .EQ. WRRQ))GOTO 23050 CALL MTERR(TERM,MTLU,WRTRNG) CALL WAIT(5) 23050 CONTINUE IF(.NOT. (ISTAT .EQ. PARITY))GOTO 23052 CALL MTERR(TERM,MTLU,PARITY) CALL EXEC(WRRQ,TERM,TMLMEM,-LCKLN) CALL RCABT 23052 CONTINUE IF(.NOT. (ISTAT .EQ. NTONLN))GOTO 23054 CALL MTERR(TERM,MTLU,NTONLN) CALL WAIT(5) 23054 CONTINUE IF(.NOT. (ISTAT .EQ. LCKED))GOTO 23056 CALL MTERR(TERM,MTLU,LCKED) CALL EXEC(WRRQ,TERM,TMLMEM,-LCKLN) CALL WAIT(5) CALL RCABT 23056 CONTINUE IF(.NOT.(ISTAT .EQ. WRTRNG .AND. FNTN .EQ. RDRQ))GOTO 23058 TAPEOK = .TRUE. GOTO 23059 23058 CONTINUE TAPEOK = ISTAT .EQ. 0 23059 CONTINUE GOTO 23044 23045 CONTINUE RETURN END C C sntx1 -- menu screen syntax analyzer C LOGICAL FUNCTION SNTX1(SCREEN) *, 92080-16584 REV. 2026 800429 IMPLICIT INTEGER (A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB,STRBF( *5) C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK,SRSTER C note: screen buffer to be checked DIMENSION SCREEN(1) C char pntr to option (also fld.len) DATA OPTCHR /1/ C char pointer to list lu DATA LULST /3/ C width of list lu field DATA NOLUCH /2/ C C begin analysis C SNTX1 = .TRUE. FIELD = 1 C C check for abort key C CALL RCKAB(SCREEN,SC1LN,OPTCHR,FIELD) C C isolate option character C OPT = IALF2(IGET1(SCREEN,OPTCHR)) C C check for blank option character C IF(.NOT. (OPT .EQ. BLANK))GOTO 23060 CALL RECOR(TERM,ANSEXP,FIELD) SNTX1 = .FALSE. RETURN C C check for invalid option character C 23060 CONTINUE IF(.NOT. ((OPT .NE. ARCHIV) .AND. (OPT .NE. RECOVR) .AN *D. (OPT .NE. PRGE ) .AND. (OPT .NE. LIST ) *.AND. (OPT .NE. TERMNT)))GOTO 23062 CALL RECOR(TERM,ILLANS,FIELD) SNTX1 = .FALSE. RETURN 23062 CONTINUE FIELD = 2 C C check for abort key C CALL RCKAB(SCREEN,SC1LN,NOLUCH,FIELD) C C begin syntax check of list lu field C LSTLU = NUMD(SCREEN,LULST,NOLUCH) C C check for blank lu field if option selected was ARCHIVE C IF(.NOT.(OPT .EQ. ARCHIV .OR. OPT .EQ. TERMNT))GOTO 23064 IF(.NOT. (LSTLU .NE. 0))GOTO 23066 CALL RECOR(TERM,FLDBLK,FIELD) SNTX1 = .FALSE. RETURN 23066 CONTINUE C C check for invalid lu number (if option selected was LIST) C 23064 CONTINUE IF(.NOT.(OPT .EQ. LIST))GOTO 23068 IF(.NOT.(.NOT.(LSTLU .GE. 0 .AND. LSTLU .LE. MAXLU)))GOTO 23070 CALL RECOR(TERM,BADLU,FIELD) SNTX1 = .FALSE. RETURN 23070 CONTINUE IF(.NOT.(LSTLU .EQ. 0))GOTO 23072 LSTLU = TERM GOTO 23073 23072 CONTINUE IX = GDVTP(LSTLU) IF(.NOT. (IX .NE. 0 .AND. IX .NE. 12B .AND. IX .NE. 5B .AND. IX .N *E. 7B))GOTO 23074 CALL RECOR(TERM,BDLST,FIELD) SNTX1 = .FALSE. RETURN 23074 CONTINUE 23073 CONTINUE C C check for non-numeric lu field (if option was RECOVER) C 23068 CONTINUE IF(.NOT.(OPT .EQ. RECOVR))GOTO 23076 IF(.NOT.(LSTLU .LT. 0))GOTO 23078 CALL RECOR(TERM,NUMFLD,FIELD) SNTX1 = .FALSE. RETURN 23078 CONTINUE IF(.NOT.(.NOT.(LSTLU .GE. 0 .AND. LSTLU .LE. MAXLU)))GOTO 23080 CALL RECOR(TERM,BADLU,FIELD) SNTX1 = .FALSE. RETURN 23080 CONTINUE IF(.NOT.(LSTLU .EQ. 0))GOTO 23082 LSTLU = TERM GOTO 23083 23082 CONTINUE IX = GDVTP(LSTLU) IF(.NOT. (IX .NE. 0B .AND. IX .NE. 5B .AND. IX .NE. 7B .AND. IX .N *E. 12B))GOTO 23084 CALL RECOR(TERM,BDLST,FIELD) SNTX1 = .FALSE. RETURN 23084 CONTINUE 23083 CONTINUE 23076 CONTINUE RETURN END C C sntx2 -- archive screen syntax analyzer C LOGICAL FUNCTION SNTX2(SCREEN) *, 92080-16584 REV. 2026 800225 IMPLICIT INTEGER (A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB,STRBF( *5) C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK,SRSTER C local boolean variables LOGICAL OK C boolean functions LOGICAL NAMCK LOGICAL INUM LOGICAL ISBTW LOGICAL ISBIT C screen buffer to be parsed DIMENSION SCREEN(1) C char ptr to log file name DATA FNMPT /1/ C char ptr to security code DATA SECPT /8/ C char ptr to cart.ref.no. DATA CRPT /15/ C char ptr to archive lu# DATA LUPT /22/ C number of characters in file name DATA NOFNCH/6/ C number of characters in sec. code DATA NOSCCH/6/ C number of characters in cr# DATA NOCRCH/6/ C number of characters in archive lu# DATA NOLUCH/2/ SNTX2 = .TRUE. FIELD = 1 C C check for abort key C CALL RCKAB(SCREEN,SC2LN,NOFNCH,FIELD) C C no abort -- parse file name C CALL MOVCA(SCREEN,FNMPT,FILENM,1,NOFNCH) CALL JUSTF(FILENM,1,NOFNCH,1) OK = .NOT.NAMCK(FILENM) IF(.NOT. (.NOT.OK))GOTO 23086 CALL RECOR(TERM,BDFLNM,FIELD) SNTX2 = .FALSE. RETURN 23086 CONTINUE FIELD = 2 C C check for abort key C CALL RCKAB(SCREEN,SC2LN,NOSCCH,FIELD) C C no abort -- parse security code C OK = .NOT.INUM(SCREEN,SECPT,NOSCCH,SECCD) IF(.NOT. (.NOT.OK))GOTO 23088 CALL JUSTF(SCREEN,SECPT,NOSCCH,1) L = LNCAR(SCREEN,SECPT,NOSCCH) IF(.NOT. (L .NE. 2))GOTO 23090 CALL RECOR(TERM,BDSC,FIELD) SNTX2 = .FALSE. RETURN 23090 CONTINUE CALL MOVCA(SCREEN,SECPT,TEMP,1,2) IF(.NOT.(ISBTW(TEMP,2HAA,2HZZ)))GOTO 23092 CALL RECOR(TERM,BDSC,FIELD) SNTX2 = .FALSE. RETURN 23092 CONTINUE SECCD = TEMP 23088 CONTINUE FIELD = 3 C C check for abort key C CALL RCKAB(SCREEN,SC2LN,NOCRCH,FIELD) C C no abort -- parse cartridge reference number C OK = .NOT.INUM(SCREEN,CRPT,NOCRCH,CTRFNO) IF(.NOT. (.NOT.OK))GOTO 23094 CALL JUSTF(SCREEN,CRPT,NOCRCH) L = LNCAR(SCREEN,CRPT,NOCRCH) IF(.NOT. (L .NE. 2))GOTO 23096 CALL RECOR(TERM,BDCRNO,FIELD) SNTX2 = .FALSE. RETURN 23096 CONTINUE CALL MOVCA(SCREEN,CRPT,TEMP,1,2) IF(.NOT.(ISBTW(TEMP,2HAA,2HZZ)))GOTO 23098 CALL RECOR(TERM,BDCRNO,FIELD) SNTX2 = .FALSE. RETURN 23098 CONTINUE CTRFNO = TEMP 23094 CONTINUE OK = ICRLU(CTRFNO) .NE. -1 IF(.NOT. (.NOT.OK))GOTO 23100 CALL RECOR(TERM,CRNMTD,FIELD) SNTX2 = .FALSE. RETURN 23100 CONTINUE FIELD = 4 C C check for abort key C CALL RCKAB(SCREEN,SC2LN,NOLUCH,FIELD) C C no abort -- parse archive lu# C OK = .NOT.INUM(SCREEN,LUPT,NOLUCH,ARLU) IF(.NOT. (.NOT.OK .OR. .NOT.(ARLU .GE. 0 .AND. ARLU .LE. MAXLU)))G *OTO 23102 CALL RECOR(TERM,BADLU,FIELD) SNTX2 = .FALSE. RETURN C C syntax check finished -- is archive lu a mag tape? C 23102 CONTINUE DVTYP = GDVTP(ARLU) IF(.NOT. (DVTYP .NE. MTDVNO))GOTO 23104 CALL MOVCA(SCREEN,LUPT,TEMP,1,NOLUCH) TEMP = NUMD(TEMP,1,NOLUCH) TEMP = IASC(TEMP) CALL RECOR(TERM,ARDNMT,FIELD,TEMP) SNTX2 = .FALSE. RETURN C C call OPEN to open log file C 23104 CONTINUE CALL OPEN(DCB,IER,FILENM,0,SECCD,CTRFNO) C C check for OPEN errors C FIELD = 1 IF(.NOT. (IER .EQ. GONE))GOTO 23106 CALL RECOR(TERM,NOTFND,FIELD) SNTX2 = .FALSE. RETURN 23106 CONTINUE IF(.NOT. (IER .EQ. LOCKED))GOTO 23108 CALL RECOR(TERM,FLLCKD,FIELD) SNTX2 = .FALSE. RETURN 23108 CONTINUE FIELD = 2 IF(.NOT. (.NOT.ISBIT(DCB(SCCKWD),SGNBIT)))GOTO 23110 CALL RECOR(TERM,WRNGSC,FIELD) SNTX2 = .FALSE. RETURN 23110 CONTINUE FIELD = 1 IF(.NOT. (IER .LT. 0))GOTO 23112 CALL JASC(IER,FMPER,1,NOERCH) CALL RECOR(TERM,OPENER,FIELD,FMPER) SNTX2 = .FALSE. RETURN 23112 CONTINUE IF(.NOT. (IER .NE. TMPTYP))GOTO 23114 CALL RECOR(TERM,NTDCP,FIELD) SNTX2 = .FALSE. CALL CLOSE(DCB) RETURN 23114 CONTINUE END C C snt36 -- purge/list#1 screen syntax analyzer C LOGICAL FUNCTION SNT36(SCREEN,FLTYP) *, 92080-16584 REV. 2026 800428 IMPLICIT INTEGER(A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB,STRBF( *5) C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK,SRSTER C local boolean variables LOGICAL OK C boolean functions LOGICAL NAMCK LOGICAL INUM LOGICAL ISBTW LOGICAL ISSPA LOGICAL ISBIT C screen buffer to be parsed DIMENSION SCREEN(1) C char ptr to log lu# DATA LUPT /1/ C char ptr to file name DATA FNMPT /4/ C char ptr to security code DATA SECPT /11/ C char ptr cart ref # DATA CRPT /18/ C number of characters in lu field DATA NOLUCH /2/ C number of characters in file name DATA NOFNCH /6/ C number of characters in security code DATA NOSCCH /6/ C number of characters in CR# DATA NOCRCH /6/ SNT36 = .TRUE. FIELD = 1 C C check for abort key C CALL RCKAB(SCREEN,SC36LN,NOLUCH,FIELD) C C no abort -- parse lu number C OK = .NOT.INUM(SCREEN,LUPT,NOLUCH,ARLU) IF(.NOT. (.NOT.OK .OR. .NOT.(ARLU .GE. 0 .AND. ARLU .LE. MAXLU)))G *OTO 23116 CALL RECOR(TERM,BADLU,FIELD) SNT36 = .FALSE. RETURN C C check to see if lu is a mag tape C 23116 CONTINUE IF(.NOT.(ARLU .NE. 0))GOTO 23118 DVTYP = GDVTP(ARLU) IF(.NOT. (DVTYP .NE. MTDVNO))GOTO 23120 CALL MOVCA(SCREEN,LUPT,TEMP,1,NOLUCH) TEMP = NUMD(TEMP,1,NOLUCH) TEMP = IASC(TEMP) CALL RECOR(TERM,ARDNMT,FIELD,TEMP) SNT36 = .FALSE. RETURN 23120 CONTINUE FLTYP = UNIT GOTO 23119 23118 CONTINUE FLTYP = FILE C C check for abort key in next three fields C 23119 CONTINUE FIELD = 2 CALL RCKAB(SCREEN,SC36LN,NOFNCH,FIELD) FIELD = 3 CALL RCKAB(SCREEN,SC36LN,NOSCCH,FIELD) FIELD = 4 CALL RCKAB(SCREEN,SC36LN,NOCRCH,FIELD) C C no abort -- make sure next 3 fields are blank if lu was specified C FIELD = 2 OK =.NOT.((ISSPA(SCREEN,FNMPT,NOFNCH) .OR. ISSPA(SCREEN,SECPT,NOSC *CH) .OR. ISSPA(SCREEN,CRPT,NOCRCH)) .AND. (FLTYP .EQ. U *NIT)) IF(.NOT. (.NOT.OK))GOTO 23122 CALL RECOR(TERM,NOFLLU,FIELD) SNT36 = .FALSE. RETURN 23122 CONTINUE IF(.NOT. (FLTYP .EQ. FILE))GOTO 23124 C C parse file name C CALL MOVCA(SCREEN,FNMPT,FILENM,1,NOFNCH) CALL JUSTF(FILENM,1,NOFNCH,1) OK = .NOT.NAMCK(FILENM) IF(.NOT. (.NOT.OK))GOTO 23126 CALL RECOR(TERM,BDFLNM,FIELD) SNT36 = .FALSE. RETURN 23126 CONTINUE FIELD = 3 C C parse security code C OK = .NOT.INUM(SCREEN,SECPT,NOSCCH,SECCD) IF(.NOT. (.NOT.OK))GOTO 23128 CALL JUSTF(SCREEN,SECPT,NOSCCH,1) L = LNCAR(SCREEN,SECPT,NOSCCH) IF(.NOT. (L .NE. 2))GOTO 23130 CALL RECOR(TERM,BDSC,FIELD) SNT36 = .FALSE. RETURN 23130 CONTINUE CALL MOVCA(SCREEN,SECPT,TEMP,1,2) IF(.NOT. (ISBTW(TEMP,2HAA,2HZZ)))GOTO 23132 CALL RECOR(TERM,BDSC,FIELD) SNT36 = .FALSE. RETURN 23132 CONTINUE SECCD = TEMP 23128 CONTINUE FIELD = 4 C C parse cart. ref. number C OK = .NOT.INUM(SCREEN,CRPT,NOCRCH,CTRFNO) IF(.NOT. (.NOT.OK))GOTO 23134 CALL JUSTF(SCREEN,CRPT,NOCRCH,1) L = LNCAR(SCREEN,CRPT,NOCRCH) IF(.NOT. (L .NE. 2))GOTO 23136 CALL RECOR(TERM,BDCRNO,FIELD) SNT36 = .FALSE. RETURN 23136 CONTINUE CALL MOVCA(SCREEN,CRPT,TEMP,1,2) IF(.NOT.(ISBTW(TEMP,2HAA,2HZZ)))GOTO 23138 CALL RECOR(TERM,BDCRNO,FIELD) SNT36 = .FALSE. RETURN 23138 CONTINUE CTRFNO = TEMP C C check to see if cart. is mounted C 23134 CONTINUE OK = ICRLU(CTRFNO) .NE. -1 IF(.NOT. (.NOT.OK))GOTO 23140 CALL RECOR(TERM,CRNMTD,FIELD) SNT36 = .FALSE. RETURN C C syntax check finished -- open log file C 23140 CONTINUE CALL OPEN(DCB,IER,FILENM,0,SECCD,CTRFNO) C C check for OPEN errors C FIELD = 2 IF(.NOT. (IER .EQ. GONE))GOTO 23142 CALL RECOR(TERM,NOTFND,FIELD) SNT36 = .FALSE. RETURN 23142 CONTINUE IF(.NOT.(IER .EQ. LOCKED))GOTO 23144 CALL RECOR(TERM,FLLCKD,FIELD) SNT36 = .FALSE. RETURN 23144 CONTINUE FIELD = 3 IF(.NOT. (.NOT.ISBIT(DCB(SCCKWD),SGNBIT)))GOTO 23146 CALL RECOR(TERM,WRNGSC,FIELD) SNT36 = .FALSE. CALL CLOSE(DCB) RETURN 23146 CONTINUE FIELD = 2 IF(.NOT. (IER .LT. 0))GOTO 23148 CALL JASC(IER,FMPER,1,NOERCH) CALL RECOR(TERM,OPENER,FIELD,FMPER) SNT36 = .FALSE. RETURN 23148 CONTINUE IF(.NOT. (IER .NE. TMPTYP))GOTO 23150 CALL RECOR(TERM,NTDCP,FIELD) SNT36 = .FALSE. CALL CLOSE (DCB) RETURN 23150 CONTINUE CALL CLOSE(DCB) 23124 CONTINUE RETURN END C C purg -- purge request processor C SUBROUTINE PURG(FLTYP) *, 92080-16584 REV. 2026 800311 IMPLICIT INTEGER (A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB,STRBF( *5) C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK,SRSTER DIMENSION LOGDES(8) LOGICAL PURGOK LOGICAL OKPRG LOGICAL CMPW DATA LOGDES/2HTM,2HS ,2HLO,2HG ,2H: ,2HDC,2HLO,2HG / DATA HDRLN/16/ DATA NOTDC/2/ PURGOK = OKPRG(TERM) IF(.NOT. (PURGOK))GOTO 23152 IF(.NOT. (FLTYP .EQ. FILE))GOTO 23154 C C hope nothing happened to file between C open/close in screen syntax chk and here!! C CALL PURGE(DCB,IER,FILENM,SECCD,CTRFNO) IF(.NOT.(IER .LT. 0))GOTO 23156 CALL JASC(IER,FMPER,1,NOERCH) CALL RECOR(TERM,PURGER,FIELD,FMPER) CALL WAIT(7) GO TO RTNPT 23156 CONTINUE GOTO 23155 23154 CONTINUE CALL MTHND(TERM,ARLU,WRRQ,.FALSE.) CALL REIO(RDRQ,ARLU,INBUFR,HDRLN) IF(.NOT. (.NOT.CMPW(INBUFR(9),LOGDES,8)))GOTO 23158 CALL RUNER(TERM,NOTDC) CALL EXEC(CTLRQ,RWSTBY+ARLU) CALL STALL(FLTYP) RETURN GOTO 23159 23158 CONTINUE CALL EXEC(CTLRQ,RWND+ARLU) CALL EXEC(CTLRQ,ERASE+ARLU) CALL EXEC(CTLRQ,RWND+ARLU) CALL EXEC(CTLRQ,WREOF+ARLU) CALL EXEC(CTLRQ,WREOF+ARLU) CALL EXEC(CTLRQ,RWSTBY+ARLU) 23159 CONTINUE 23155 CONTINUE 23152 CONTINUE RETURN END C C snt57 -- list#2/partial recovery screen syntax analyzer C LOGICAL FUNCTION SNT57(SCREEN,SCRNM,FNTN,TMYR1,DATE1,TMHR1, * TMMN1,TMSC1,TMMS1,TMYR2,DATE2,TMHR2,TMMN2,TMSC2,TMMS2) *, 92080-16584 REV. 2026 800213 IMPLICIT INTEGER(A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB,STRBF( *5) C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK,SRSTER C C screen buffer C DIMENSION SCREEN(1) C C boolean functions C LOGICAL ISSPA C C boolean variables C LOGICAL ALLOK LOGICAL BKDAT1 LOGICAL BKDAT2 LOGICAL BKTIM1 LOGICAL BKTIM2 C C local constants -- field lengths C DATA FNFLDL/1/ DATA YRFLDL/4/ DATA MOFLDL/2/ DATA DAFLDL/2/ DATA HRFLDL/2/ DATA MNFLDL/2/ DATA SCFLDL/2/ DATA MSFLDL/2/ C C local constants -- byte pointers to data items in screen buffer C DATA FCNPT/1/ DATA TYR1PT/3/ DATA TMO1PT/8/ DATA TDA1PT/11/ DATA THR1PT/14/ DATA TMN1PT/17/ DATA TSC1PT/20/ DATA TMS1PT/23/ DATA TYR2PT/26/ DATA TMO2PT/31/ DATA TDA2PT/34/ DATA THR2PT/37/ DATA TMN2PT/40/ DATA TSC2PT/43/ DATA TMS2PT/46/ C C miscellaneous local constants C DATA LSTSCR/7/ DATA RCVSCR/5/ DATA MAXHR/23/ DATA MXMNSC/59/ DATA MAXDAY/366/ DATA MAXMSC/99/ SNT57 = .TRUE. C C check for abort key in all fields C C function field FIELD = 1 CALL RCKAB(SCREEN,SC57LN,FNFLDL,FIELD) C time stmp. year fields FIELD = 2 FIELD2= 9 CALL RCKAB(SCREEN,SC57LN,YRFLDL,FIELD) CALL RCKAB(SCREEN,SC57LN,YRFLDL,FIELD2) C time stmp. month fields FIELD = 3 FIELD2= 10 CALL RCKAB(SCREEN,SC57LN,MOFLDL,FIELD) CALL RCKAB(SCREEN,SC57LN,MOFLDL,FIELD2) C time stmp. day fields FIELD = 4 FIELD2= 11 CALL RCKAB(SCREEN,SC57LN,DAFLDL,FIELD) CALL RCKAB(SCREEN,SC57LN,DAFLDL,FIELD2) C time stmp. hour fields FIELD = 5 FIELD2= 12 CALL RCKAB(SCREEN,SC57LN,HRFLDL,FIELD) CALL RCKAB(SCREEN,SC57LN,HRFLDL,FIELD2) C time stmp. minute fields FIELD = 6 FIELD2= 13 CALL RCKAB(SCREEN,SC57LN,MNFLDL,FIELD) CALL RCKAB(SCREEN,SC57LN,MNFLDL,FIELD2) C time stmp. second fields FIELD = 7 FIELD2= 14 CALL RCKAB(SCREEN,SC57LN,SCFLDL,FIELD) CALL RCKAB(SCREEN,SC57LN,SCFLDL,FIELD2) C time stmp. msec. fields FIELD = 8 FIELD2= 15 CALL RCKAB(SCREEN,SC57LN,MSFLDL,FIELD) CALL RCKAB(SCREEN,SC57LN,MSFLDL,FIELD2) C C whew!...no abort found...isolate function to be performed C FIELD = 1 FNTN = IALF2(IGET1(SCREEN,FCNPT)) C C check to see if an answer was specified C IF(.NOT.(FNTN .EQ. BLANK))GOTO 23160 CALL RECOR(TERM,ANSEXP,FIELD) SNT57 = .FALSE. RETURN C C an answer was given -- is it a valid one C 23160 CONTINUE ALLOK = (FNTN .EQ. THRU .OR. FNTN .EQ. AFTER * .OR. FNTN .EQ. INCL .OR. * FNTN .EQ. NTINCL.OR. FNTN .EQ. COMP) IF(.NOT.(.NOT.ALLOK))GOTO 23162 CALL RECOR(TERM,ILLANS,FIELD) SNT57 = .FALSE. RETURN 23162 CONTINUE IF(.NOT.(SCRNM .NE. LSTSCR .AND. FNTN .EQ. COMP))GOTO 23164 CALL RECOR(TERM,ILLANS,FIELD) SNT57 = .FALSE. RETURN C C valid answer given -- set some booleans about blank fields C before dispatching on function C 23164 CONTINUE BKDAT1 = .NOT.ISSPA(SCREEN,TYR1PT,YRFLDL) .AND. * .NOT.ISSPA(SCREEN,TMO1PT,MOFLDL) .AND. .NOT.IS *SPA(SCREEN,TDA1PT,DAFLDL) BKDAT2 = .NOT.ISSPA(SCREEN,TYR2PT,YRFLDL) .AND. * .NOT.ISSPA(SCREEN,TMO2PT,MOFLDL) .AND. .NOT.IS *SPA(SCREEN,TDA2PT,DAFLDL) BKTIM1 = .NOT.ISSPA(SCREEN,THR1PT,HRFLDL) .AND. * .NOT.ISSPA(SCREEN,TMN1PT,MNFLDL) .AND. .NOT.IS *SPA(SCREEN,TSC1PT,SCFLDL) .AND. .NOT.ISSPA(SCRE *EN,TMS1PT,MSFLDL) BKTIM2 = .NOT.ISSPA(SCREEN,THR2PT,HRFLDL) .AND. * .NOT.ISSPA(SCREEN,TMN2PT,MNFLDL) .AND. .NOT.IS *SPA(SCREEN,TSC2PT,SCFLDL) .AND. .NOT.ISSPA(SCRE *EN,TMS2PT,MSFLDL) C C convert all fields to numbers C (note: 'numd' returns -1 if it fails) C TMYR1 = NUMD(SCREEN,TYR1PT,YRFLDL) TMYR2 = NUMD(SCREEN,TYR2PT,YRFLDL) TMMO1 = NUMD(SCREEN,TMO1PT,MOFLDL) TMMO2 = NUMD(SCREEN,TMO2PT,MOFLDL) TMDA1 = NUMD(SCREEN,TDA1PT,DAFLDL) TMDA2 = NUMD(SCREEN,TDA2PT,DAFLDL) TMHR1 = NUMD(SCREEN,THR1PT,HRFLDL) TMHR2 = NUMD(SCREEN,THR2PT,HRFLDL) TMMN1 = NUMD(SCREEN,TMN1PT,MNFLDL) TMMN2 = NUMD(SCREEN,TMN2PT,MNFLDL) TMSC1 = NUMD(SCREEN,TSC1PT,SCFLDL) TMSC2 = NUMD(SCREEN,TSC2PT,SCFLDL) TMMS1 = NUMD(SCREEN,TMS1PT,MSFLDL) TMMS2 = NUMD(SCREEN,TMS2PT,MSFLDL) C C convert mo/da/yr date to julian date C (note: 'julia' returns -1 if it fails) C DATE1 = JULIA(TMDA1,TMMO1,TMYR1) DATE2 = JULIA(TMDA2,TMMO2,TMYR2) C C this code does syntax check C based on the function to be performed C IF(.NOT.(FNTN .EQ. COMP))GOTO 23166 FIELD = 2 ALLOK = BKDAT1 .AND. BKDAT2 .AND. BKTIM1 .AND. BKTIM2 IF(.NOT. (.NOT.ALLOK))GOTO 23168 CALL RECOR(TERM,TMSTBK,FIELD) SNT57 = .FALSE. RETURN 23168 CONTINUE C C check for required blank/non-blank fields in thru/after cases C 23166 CONTINUE IF(.NOT.(FNTN .EQ. THRU .OR. FNTN .EQ. AFTER))GOTO 23 *170 FIELD = 2 ALLOK = BKDAT1 .OR. BKTIM1 IF(.NOT.(ALLOK))GOTO 23172 CALL RECOR(TERM,INCTST,FIELD) SNT57 = .FALSE. RETURN 23172 CONTINUE FIELD = 9 ALLOK = .NOT.(BKDAT2 .AND. BKTIM2) IF(.NOT.(ALLOK))GOTO 23174 CALL RECOR(TERM,TTSFBK,FIELD) SNT57 = .FALSE. RETURN 23174 CONTINUE C C check to make sure no time stamp fields are blank C for included/not-included cases C 23170 CONTINUE IF(.NOT.(FNTN .EQ. INCL .OR. FNTN .EQ. NTINCL))GOTO 2 *3176 FIELD = 2 ALLOK = BKDAT1 .OR. BKDAT2 .OR. BKTIM1 .OR. BKTIM2 IF(.NOT.(ALLOK))GOTO 23178 CALL RECOR(TERM,NTSFBK,FIELD) SNT57 = .FALSE. RETURN 23178 CONTINUE C C eliminated required blank/non-blank fields cases C check the validity of the data in time stamp #1 C 23176 CONTINUE IF(.NOT.(FNTN .NE. COMP))GOTO 23180 FIELD = 2 IF(.NOT.(DATE1 .LT. 0 .OR. DATE1 .GT. MAXDAY))GOTO 23182 CALL RECOR(TERM,DATERR,FIELD) SNT57 = .FALSE. RETURN 23182 CONTINUE FIELD = 5 IF(.NOT.(TMHR1 .LT. 0 .OR. TMHR1 .GT. MAXHR))GOTO 23184 CALL RECOR(TERM,HRERR,FIELD) SNT57 = .FALSE. RETURN 23184 CONTINUE FIELD = 6 IF(.NOT.(TMMN1 .LT. 0 .OR. TMMN1 .GT. MXMNSC))GOTO 23186 CALL RECOR(TERM,MINERR,FIELD) SNT57 = .FALSE. RETURN 23186 CONTINUE FIELD = 7 IF(.NOT.(TMSC1 .LT. 0 .OR. TMSC1 .GT. MXMNSC))GOTO 23188 CALL RECOR(TERM,SECERR,FIELD) SNT57 = .FALSE. RETURN 23188 CONTINUE FIELD = 8 IF(.NOT.(TMMS1 .LT. 0 .OR. TMMS1 .GT. MAXMSC))GOTO 23190 CALL RECOR(TERM,MSCERR,FIELD) SNT57 = .FALSE. RETURN 23190 CONTINUE C C do syntax check on time stamp #2 fields if C function is include/not include C 23180 CONTINUE IF(.NOT.(FNTN .EQ. INCL .OR. FNTN .EQ. NTINCL))GOTO 2319 *2 FIELD = 9 IF(.NOT. (DATE2 .LT. 0 .OR. DATE2 .GT. MAXDAY))GOTO 23194 CALL RECOR(TERM,DATERR,FIELD) SNT57 = .FALSE. RETURN 23194 CONTINUE IF(.NOT. (DATE2 .LT. DATE1 .AND. TMYR2 .LE. TMYR1))GOTO 23196 CALL RECOR(TERM,DT1DT2,FIELD) SNT57 = .FALSE. RETURN 23196 CONTINUE FIELD = 12 IF(.NOT.(TMHR2 .LT. 0 .OR. TMHR2 .GT. MAXHR))GOTO 23198 CALL RECOR(TERM,HRERR,FIELD) SNT57 = .FALSE. RETURN 23198 CONTINUE FIELD = 13 IF(.NOT.(TMMN2 .LT. 0 .OR. TMMN2 .GT. MXMNSC))GOTO 23200 CALL RECOR(TERM,MINERR,FIELD) SNT57 = .FALSE. RETURN 23200 CONTINUE FIELD = 14 IF(.NOT.(TMSC2 .LT. 0 .OR. TMSC2 .GT. MXMNSC))GOTO 23202 CALL RECOR(TERM,SECERR,FIELD) SNT57 = .FALSE. RETURN 23202 CONTINUE FIELD = 15 IF(.NOT.(TMMS1 .LT. 0 .OR. TMMS1 .GT. MAXMSC))GOTO 23204 CALL RECOR(TERM,MSCERR,FIELD) SNT57 = .FALSE. RETURN 23204 CONTINUE FIELD = 12 IF(.NOT.(TMYR1 .EQ. TMYR2 .AND. DATE1 .EQ. DATE2 .AND. * (TMHR2 .LT. TMHR1 .OR. TMMN2 .LT. TMMN1 . *OR. TMSC2 .LT. TMSC1) .AND. ( *TMMS1 .LT. TMMS2)))GOTO 23206 CALL RECOR(TERM,TM1TM2,FIELD) SNT57 = .FALSE. RETURN 23206 CONTINUE C C no errors -- return C 23192 CONTINUE RETURN END C C sntx4 -- complete recovery screen analyzer C LOGICAL FUNCTION SNTX4(SCREEN,TYPE,FROM) *, 92080-16584 REV. 2026 800429 IMPLICIT INTEGER (A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB,STRBF( *5) C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK,SRSTER C screen data buffer DIMENSION SCREEN(1) C local boolean variables LOGICAL OK C local boolean functions LOGICAL ISSPA LOGICAL ISBTW LOGICAL INUM LOGICAL NAMCK LOGICAL ISBIT C option field length DATA OPFLDL/1/ C lock check field length DATA LKFLDL/1/ C recovery lu# field length DATA LGFLDL/2/ C log file name field length DATA FNFLDL/6/ C log file sc field length DATA SCFLDL/6/ C log file cr# field length DATA CRFLDL/6/ C audit device lu# field length DATA LSFLDL/2/ C char ptr. to option char DATA OPCHPT/1/ C char ptr. to lock check answer DATA LKCHPT/3/ C char ptr. to recvry lu# DATA LGCHPT/5/ C char ptr. to log file name DATA FNCHPT/8/ C char ptr. to log file sc DATA SCCHPT/15/ C char ptr. to log file cr# DATA CRCHPT/22/ C char ptr. to audit device lu# DATA LSCHPT/29/ SNTX4 = .TRUE. C C check for abort in all fields C C option field FIELD = 1 CALL RCKAB(SCREEN,SC4LN,OPFLDL,FIELD) C lock check field FIELD = 2 CALL RCKAB(SCREEN,SC4LN,LKFLDL,FIELD) C log lu# field FIELD = 3 CALL RCKAB(SCREEN,SC4LN,LGFLDL,FIELD) C file name field FIELD = 4 CALL RCKAB(SCREEN,SC4LN,FNFLDL,FIELD) C sc field FIELD = 5 CALL RCKAB(SCREEN,SC4LN,SCFLDL,FIELD) C cr# field FIELD = 6 CALL RCKAB(SCREEN,SC4LN,CRFLDL,FIELD) C audit lu# field FIELD = 7 CALL RCKAB(SCREEN,SC4LN,LSFLDL,FIELD) C C no abort detected ... isolate option char C FIELD = 1 TYPE = IALF2(IGET1(SCREEN,OPCHPT)) C C see if answer was given C IF(.NOT.(TYPE .EQ. BLANK))GOTO 23208 CALL RECOR(TERM,ANSEXP,FIELD) SNTX4 = .FALSE. RETURN C C answer was given ... is it valid? C 23208 CONTINUE IF(.NOT.(TYPE .NE. COMP .AND. TYPE .NE. PART))GOTO 23 *210 CALL RECOR(TERM,ILLANS,FIELD) SNTX4 = .FALSE. RETURN C C valid option selected ... check lock check response C 23210 CONTINUE FIELD = 2 LCKCHK = IALF2(IGET1(SCREEN,LKCHPT)) C C reject anything but 'Y' or 'N' (force an answer!) C IF(.NOT.(LCKCHK .EQ. BLANK))GOTO 23212 CALL RECOR(TERM,ANSEXP,FIELD) SNTX4 = .FALSE. RETURN 23212 CONTINUE IF(.NOT.(LCKCHK .NE. YES .AND. LCKCHK .NE. NO))GOTO 2 *3214 CALL RECOR(TERM,ILLANS,FIELD) SNTX4 = .FALSE. RETURN C C check audit lu field C 23214 CONTINUE FIELD = 7 OK = .NOT.INUM(SCREEN,LSCHPT,LSFLDL,LSTLU) IF(.NOT.(.NOT.OK))GOTO 23216 CALL RECOR(TERM,BADLU,FIELD) SNTX4 = .FALSE. RETURN C C default to this terminal C 23216 CONTINUE IF(.NOT. (LSTLU .EQ. 0))GOTO 23218 LSTLU = TERM GOTO 23219 23218 CONTINUE IX = GDVTP(LSTLU) IF(.NOT. (IX .NE. 0B .AND. IX .NE. 5B .AND. IX .NE. 7B .AND. IX .N *E. 12B))GOTO 23220 CALL RECOR(TERM,BDLST,FIELD) SNTX4 = .FALSE. RETURN 23220 CONTINUE C C find out where data to be recovered is coming from C 23219 CONTINUE FIELD = 3 OK = .NOT.INUM(SCREEN,LGCHPT,LGFLDL,ARLU) IF(.NOT. (.NOT.OK .OR. .NOT.(ARLU .GE.0 .AND. ARLN .LE. MAXLU)))GO *TO 23222 CALL RECOR(TERM,BADLU,FIELD) SNTX4 = .FALSE. RETURN C C check to see if lu is a mag-tape C 23222 CONTINUE IF(.NOT.(ARLU .NE. 0))GOTO 23224 DVTYP = GDVTP(ARLU) IF(.NOT.(DVTYP .NE. MTDVNO))GOTO 23226 CALL MOVCA(SCREEN,LGCHPT,TEMP,1,LGFLDL) TEMP = IASC(NUMD(TEMP,1,LGFLDL)) CALL RECOR(TERM,ARDNMT,FIELD,TEMP) SNTX4 = .FALSE. RETURN 23226 CONTINUE FROM = UNIT GOTO 23225 23224 CONTINUE FROM = FILE C C check namr fields ... make sure they're blank if lu was given C 23225 CONTINUE FIELD = 4 OK = .NOT.((ISSPA(SCREEN,FNCHPT,FNFLDL) .OR. ISS *PA(SCREEN,SCCHPT,SCFLDL) .OR. ISSPA(SCREEN,CRCHP *T,CRFLDL)) .AND. FROM .EQ. UNIT) IF(.NOT.(.NOT.OK))GOTO 23228 CALL RECOR(TERM,NOFLLU,FIELD) SNTX4 = .FALSE. RETURN 23228 CONTINUE IF(.NOT.(FROM .EQ. FILE))GOTO 23230 C C parse file name C CALL MOVCA(SCREEN,FNCHPT,FILENM,1,FNFLDL) CALL JUSTF(FILENM,1,FNFLDL,1) OK = .NOT.NAMCK(FILENM) IF(.NOT.(.NOT.OK))GOTO 23232 CALL RECOR(TERM,BDFLNM,FIELD) SNTX4 = .FALSE. RETURN C C parse security code C 23232 CONTINUE FIELD = 5 OK = .NOT.INUM(SCREEN,SCCHPT,SCFLDL,SECCD) IF(.NOT. (.NOT.OK))GOTO 23234 CALL JUSTF(SCREEN,SCCHPT,SCFLDL,1) L = LNCAR(SCREEN,SCCHPT,SCFLDL) IF(.NOT. (L .NE. 2))GOTO 23236 CALL RECOR(TERM,BDSC,FIELD) SNTX4 = .FALSE. RETURN 23236 CONTINUE CALL MOVCA(SCREEN,SCCHPT,TEMP,1,2) IF(.NOT.(ISBTW(TEMP,2HAA,2HZZ)))GOTO 23238 CALL RECOR(TERM,BDSC,FIELD) SNTX4 = .FALSE. RETURN 23238 CONTINUE SECCD = TEMP C C parse cr# C 23234 CONTINUE FIELD = 6 OK = .NOT.INUM(SCREEN,CRCHPT,CRFLDL,CTRFNO) IF(.NOT.(.NOT.OK))GOTO 23240 CALL JUSTF(SCREEN,CRCHPT,CRFLDL,1) L = LNCAR(SCREEN,CRCHPT,CRFLDL) IF(.NOT. (L .NE. 2))GOTO 23242 CALL RECOR(TERM,BDCRNO,FIELD) SNTX4 = .FALSE. RETURN 23242 CONTINUE CALL MOVCA(SCREEN,CRCHPT,TEMP,1,2) IF(.NOT.(ISBTW(TEMP,2HAA,2HZZ)))GOTO 23244 CALL RECOR(TERM,BDCRNO,FIELD) SNTX4 = .FALSE. RETURN 23244 CONTINUE CTRFNO = TEMP C C check to see if cr is mounted C 23240 CONTINUE OK = ICRLU(CTRFNO) .NE. -1 IF(.NOT.(.NOT.OK))GOTO 23246 CALL RECOR(TERM,CRNMTD,FIELD) SNTX4 = .FALSE. RETURN C C syntax check finished -- open file C 23246 CONTINUE CALL OPEN(DCB,IER,FILENM,0,SECCD,CTRFNO) C C check for OPEN errors C FIELD = 4 IF(.NOT. (IER .EQ. GONE))GOTO 23248 CALL RECOR(TERM,NOTFND,FIELD) SNTX4 = .FALSE. RETURN 23248 CONTINUE IF(.NOT.(IER .EQ. LOCKED))GOTO 23250 CALL RECOR(TERM,FLLCKD,FIELD) SNTX4 = .FALSE. RETURN 23250 CONTINUE FIELD = 5 IF(.NOT. (.NOT.ISBIT(DCB(SCCKWD),SGNBIT)))GOTO 23252 CALL RECOR(TERM,WRNGSC,FIELD) SNTX4 = .FALSE. RETURN 23252 CONTINUE FIELD = 4 IF(.NOT. (IER .LT. 0))GOTO 23254 CALL JASC(IER ,FMPER,1,NOERCH) CALL RECOR(TERM,OPENER,FIELD,FMPER) SNTX4 = .FALSE. RETURN 23254 CONTINUE IF(.NOT. (IER .NE. TMPTYP))GOTO 23256 CALL RECOR(TERM,NTDCP,FIELD) SNTX4 = .FALSE. CALL CLOSE (DCB) RETURN C C everything ok ... close the log file for recov. C 23256 CONTINUE CALL CLOSE(DCB) 23230 CONTINUE RETURN END C C C SUBROUTINE TPHND(FNTN,TYPE,YR1,DATE1,HR1,MN1,SC1,MSC1, * YR2,DATE2,HR2,MN2,SC2,MSC2) *, 92080-16584 REV. 2026 800430 IMPLICIT INTEGER (A-Y) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK DIMENSION LOGDES(8),TMPHDR(16),EOTMG(23),EOTMG2(19) DIMENSION TPENMG(23) LOGICAL CMPW LOGICAL JULIB LOGICAL ISBIT LOGICAL ISBTW LOGICAL OK LOGICAL RCETFL LOGICAL HDOK DATA EOTMG/2HEn,2Hd ,2Hof,2H t,2Hap,2He ,2Hde,2Hte,2Hct,2Hed,2H! , *2H R,2Heq,2Hue,2Hst,2Hin,2Hg ,2HRE,2HEL,2H #,2H x,2Hxx,2Hx / DATA EOTMG2/2H ,2H ,2H .,2H..,2HPr,2Hes,2Hs ,2HEN,2HTE,2HR ,2Hto *,2H a,2Hck,2Hno,2Hwl,2Hed,2Hge,2H. ,2H / DATA ETLN2/19/ DATA RNPTR/42/ DATA EOTLN/23/ DATA TPENMG/2HEn,2Hd ,2Hof,2H t,2Hap,2He ,2Hde,2Hte,2Hct,2Hed,2H! *,2H P,2Hle,2Has,2He ,2Hmo,2Hun,2Ht ,2Hne,2Hxt,2H r,2Hee,2Hl./ DATA TPENLN/23/ DATA HDRLN /16/ DATA DESWD/9/ DATA DESLN/8/ DATA RLNOPT/8/ DATA YRWDPT/7/ DATA JDAWPT/6/ DATA HRWDPT/5/ DATA MNWDPT/4/ DATA SCWDPT/3/ DATA MSWDPT/2/ DATA RCUNSN/9/ DATA LSUNSN/10/ DATA ARUNSN/11/ DATA CORRPT/1/ DATA NOTDC/2/ DATA RDFER/3/ DATA RCCRPT/4/ DATA BTIMST/5/ DATA EOFFND/6/ DATA LOGDES/2HTM,2HS ,2HLO,2HG ,2H: ,2HDC,2HLO,2HG / C C local functions C ZCDAT(M1,M2) = M1*1000. + M2 ZCTIM(M1,M2,M3,M4) = (M1*3600.+M2*60.+M3) * 100. + M4 C C do polynomial on dates/times passed as arguments C ZTIM1 = ZCTIM(HR1,MN1,SC1,MSC1) ZTIM2 = ZCTIM(HR2,MN2,SC2,MSC2) ZDAT1 = ZCDAT(YR1,DATE1) ZDAT2 = ZCDAT(YR2,DATE2) RCETFL = .FALSE. C C open the right file C 409 REELNO = 1 HDOK = .FALSE. CONTINUE 23000 IF(.NOT. (.NOT.HDOK))GOTO 23001 HDOK = .TRUE. IF(.NOT.(TYPE .EQ. FILE))GOTO 23002 CALL OPEN(DCB,IER,FILENM,0,SECCD,CTRFNO) GOTO 23003 23002 CONTINUE CALL MTHND(TERM,ARLU,RDRQ,RCETFL) RCETFL = .FALSE. CALL OPENF(DCB,IER,ARLU) 23003 CONTINUE IF(.NOT.(OPT .EQ. LIST))GOTO 23004 CALL RECSC(TERM,LSUNSN) IF(.NOT. (LSTLU .NE. TERM))GOTO 23006 CALL LURQ(LULCK,LSTLU,1) 23006 CONTINUE 23004 CONTINUE IF(.NOT.(OPT .EQ. RECOVR))GOTO 23008 CALL RECSC(TERM,RCUNSN) IF(.NOT.(LSTLU .NE. TERM))GOTO 23010 CALL LURQ(LULCK,LSTLU,1) 23010 CONTINUE 23008 CONTINUE IF(.NOT.(OPT .EQ. ARCHIV))GOTO 23012 CALL MTHND(TERM,ARLU,WRRQ,.FALSE.) CALL RECSC(TERM,ARUNSN) C C read the header C 23012 CONTINUE CALL READF(DCB,IER,INBUFR,MXRCLN,LEN) C C check for corrupt tape or file C IF(.NOT.(IER .LT. 0 .OR. LEN .NE. HDRLN))GOTO 23014 CALL RUNER(TERM,CORRPT) IF(.NOT.(TYPE .EQ. UNIT))GOTO 23016 CALL FCONT(DCB,IER,RWSTBY) CALL CLOSE(DCB) CALL STALL(TYPE) HDOK = .FALSE. GOTO 23017 23016 CONTINUE CALL CLOSE(DCB) CALL STALL(TYPE) GO TO RTNPT 23017 CONTINUE 23014 CONTINUE IF(.NOT.(.NOT.HDOK))GOTO 23018 GOTO 23000 23018 CONTINUE HDOK = .TRUE. OK = CMPW(INBUFR(DESWD),LOGDES,DESLN) IF(.NOT.(.NOT.OK))GOTO 23020 CALL RUNER(TERM,NOTDC) IF(.NOT.(TYPE .EQ. UNIT))GOTO 23022 CALL FCONT(DCB,IER,RWSTBY) CALL CLOSE(DCB) CALL STALL(TYPE) HDOK = .FALSE. GOTO 23023 23022 CONTINUE CALL CLOSE(DCB) CALL STALL(TYPE) GO TO RTNPT 23023 CONTINUE 23020 CONTINUE IF(.NOT.(.NOT.HDOK))GOTO 23024 GOTO 23000 23024 CONTINUE C C its a good log -- write the header on the list/audit device C or record it on the archive device if required C GOTO 23000 23001 CONTINUE IF(.NOT.(OPT .EQ. ARCHIV))GOTO 23026 CALL MOVEW(INBUFR,TMPHDR,HDRLN) TMPHDR(RLNOPT) = -REELNO CALL REIO(WRRQ,ARLU,TMPHDR,HDRLN) CALL VERFY(TERM,ARLU,1,TMPHDR,HDRLN) GOTO 23027 23026 CONTINUE CALL LISTR(LEN,TYPE,HEADR,RECNO,TAPHN) C C tape read loop C 23027 CONTINUE OK = .TRUE. RECNO = 1 CONTINUE 23028 IF(.NOT. (OK))GOTO 23029 C C set time and date of previous record C CALL MOVEW(INBUFR(MSWDPT),TMPHDR(MSWDPT),6) ZDATEO = ZCDAT(INBUFR(YRWDPT),INBUFR(JDAWPT)) ZTIMEO = ZCTIM(INBUFR(HRWDPT),INBUFR(MNWDPT) * ,INBUFR(SCWDPT),INBUFR(MSWDPT)) C C read a new record C CALL READF(DCB,IER,INBUFR,MXRCLN,LEN) C C set time and date of new record C ZDATEN = ZCDAT(INBUFR(YRWDPT),INBUFR(JDAWPT)) ZTIMEN = ZCTIM(INBUFR(HRWDPT),INBUFR(MNWDPT) * ,INBUFR(SCWDPT),INBUFR(MSWDPT)) C C check to see that tape is ok and record is good C OK = IER .EQ. 0 .AND. LEN .GT. 0 .AND. LEN * .EQ. INBUFR .AND. ZDATEN .GE. ZDATEO .AND. * ZTIMEN .GE. ZTIMEO C C force a loop termination if 'ok' is false C IF(.NOT. (.NOT.OK))GOTO 23030 GOTO 23028 C C accept or reject record based on function selected C and time stamp in record C 23030 CONTINUE IF(.NOT.(FNTN .EQ. COMP))GOTO 23032 IF(.NOT.(LEN .EQ. HDRLN))GOTO 23034 IF(.NOT. (OPT .EQ. LIST))GOTO 23036 CALL LISTR(LEN,TYPE,HEADR,RECNO,TAPHN) 23036 CONTINUE IF(.NOT. (OPT .EQ. RECOVR))GOTO 23038 CALL RECVR(LEN,TYPE,HEADR,RECNO) 23038 CONTINUE GOTO 23035 23034 CONTINUE IF(.NOT.(OPT .EQ. LIST))GOTO 23040 CALL LISTR(LEN,TYPE,RECRD,RECNO,TAPHN) 23040 CONTINUE IF(.NOT.(OPT .EQ. RECOVR))GOTO 23042 CALL RECVR(LEN,TYPE,RECRD,RECNO) 23042 CONTINUE 23035 CONTINUE IF(.NOT. (OPT .EQ. ARCHIV))GOTO 23044 380 JCODE = WRRQ + 100000B CALL EXEC(JCODE,ARLU,INBUFR,LEN) GO TO 12 CFUCKING FTN4! Q=0 12 CALL EXEC(3,600B+ARLU) CALL ABREG(IST,ITL) IST = IAND(IST,377B) IF(.NOT. (IST .NE. 0 .AND. ISBIT(IST,5)))GOTO 23046 CALL EXEC(CTLRQ,WREOF+ARLU) CALL EXEC(CTLRQ,RWSTBY+ARLU) REELNO = REELNO+1 TMPHDR(RLNOPT) = -REELNO CALL JASC(REELNO,EOTMG,RNPTR,4) CALL REIO(WRRQ,TERM,EOTMG,EOTLN) CALL REIO(WRRQ,TERM,EOTMG2,ETLN2) CALL REIO(RDRQ,TERM,IX,-1) NEWRTN = RTNPT ASSIGN 356 TO RTNPT CALL RCKAB(IX,1,1,1,1) 356 RTNPT = NEWRTN CALL MTHND(TERM,ARLU,WRRQ,.FALSE.) CALL REIO(WRRQ,ARLU,TMPHDR,HDRLN) RECNO = 1 GOTO 23028 23046 CONTINUE IF(.NOT.(IST .NE. 0 .AND. .NOT.ISBIT(IST,5)))GOTO 23048 CALL LURQ(LUULK,TERM,1) CALL EXEC(13,ARLU,Q) CALL LURQ(LULCK,TERM,1) GO TO 380 23048 CONTINUE CALL VERFY(TERM,ARLU,RECNO,INBUFR,LEN) 23044 CONTINUE 23032 CONTINUE IF(.NOT.(FNTN .EQ. THRU .AND. ZDATEN .LE. ZDAT *1 .AND. ZTIMEN .LE. ZTIM1 ))GOTO 23050 IF(.NOT.(LEN .EQ. HDRLN))GOTO 23052 IF(.NOT.(OPT .EQ. LIST))GOTO 23054 CALL LISTR(LEN,TYPE,HEADR,RECNO,TAPHN) GOTO 23055 23054 CONTINUE CALL RECVR(LEN,TYPE,HEADR,RECNO) 23055 CONTINUE GOTO 23053 23052 CONTINUE IF(.NOT.(OPT .EQ. LIST))GOTO 23056 CALL LISTR(LEN,TYPE,RECRD,RECNO,TAPHN) GOTO 23057 23056 CONTINUE CALL RECVR(LEN,TYPE,RECRD,RECNO) 23057 CONTINUE 23053 CONTINUE 23050 CONTINUE IF(.NOT.(FNTN .EQ. AFTER .AND. ZDATEN .GE. ZDA *T1 .AND. ZTIMEN .GE. ZTIM1 ))GOTO 23058 IF(.NOT.(LEN .EQ. HDRLN))GOTO 23060 IF(.NOT.(OPT .EQ. LIST))GOTO 23062 CALL LISTR(LEN,TYPE,HEADR,RECNO,TAPHN) GOTO 23063 23062 CONTINUE CALL RECVR(LEN,TYPE,HEADR,RECNO) 23063 CONTINUE GOTO 23061 23060 CONTINUE IF(.NOT.(OPT .EQ. LIST))GOTO 23064 CALL LISTR(LEN,TYPE,RECRD,RECNO,TAPHN) GOTO 23065 23064 CONTINUE CALL RECVR(LEN,TYPE,RECRD,RECNO) 23065 CONTINUE 23061 CONTINUE 23058 CONTINUE IF(.NOT.(FNTN .EQ. INCL .AND. ((ZDATEN .GE. ZD *AT1 .AND. ZDATEN .LE. ZDAT2) .AND. (ZTIMEN .G *E. ZTIM1 .AND. ZTIMEN .LE. ZTIM2))))GOTO 23066 IF(.NOT.(LEN .EQ. HDRLN))GOTO 23068 IF(.NOT.(OPT .EQ. LIST))GOTO 23070 CALL LISTR(LEN,TYPE,HEADR,RECNO,TAPHN) GOTO 23071 23070 CONTINUE CALL RECVR(LEN,TYPE,HEADR,RECNO) 23071 CONTINUE GOTO 23069 23068 CONTINUE IF(.NOT.(OPT .EQ. LIST))GOTO 23072 CALL LISTR(LEN,TYPE,RECRD,RECNO,TAPHN) GOTO 23073 23072 CONTINUE CALL RECVR(LEN,TYPE,RECRD,RECNO) 23073 CONTINUE 23069 CONTINUE 23066 CONTINUE IF(.NOT.(FNTN .EQ. NTINCL .AND. .NOT.((ZDATEN . *GE. ZDAT1 .AND. ZDATEN .LE. ZDAT2) .AND. (ZTIM *EN .GE. ZTIM1 .AND. ZTIMEN .LE. ZTIM2))))GOTO 23074 IF(.NOT.(LEN .EQ. HDRLN))GOTO 23076 IF(.NOT.(OPT .EQ. LIST))GOTO 23078 CALL LISTR(LEN,TYPE,HEADR,RECNO,TAPHN) GOTO 23079 23078 CONTINUE CALL RECVR(LEN,TYPE,HEADR,RECNO) 23079 CONTINUE GOTO 23077 23076 CONTINUE IF(.NOT.(OPT .EQ. LIST))GOTO 23080 CALL LISTR(LEN,TYPE,RECRD,RECNO,TAPHN) GOTO 23081 23080 CONTINUE CALL RECVR(LEN,TYPE,RECRD,RECNO) 23081 CONTINUE 23077 CONTINUE 23074 CONTINUE RECNO = RECNO + 1 GOTO 23028 23029 CONTINUE RECNO = RECNO -1 C C end of file?? C IF(.NOT. (LEN .EQ. -1))GOTO 23082 IF(.NOT. (OPT .EQ. ARCHIV))GOTO 23084 CALL RUNER(TERM,EOFFND,RECNO) CALL EXEC(CTLRQ,WREOF+ARLU) CALL EXEC(CTLRQ,RWSTBY+ARLU) CALL CLOSE(DCB) CALL STALL(FILE) RETURN 23084 CONTINUE IF(.NOT. (TYPE .EQ. UNIT))GOTO 23086 IF(.NOT. (OPT .EQ. RECOVR))GOTO 23088 CALL EXEC(CTLRQ,600B+ARLU) CALL ABREG(IST,ILN) IF(.NOT. (ISBIT(IST,5)))GOTO 23090 CALL FCONT(DCB,IER,RWSTBY) CALL REIO(WRRQ,TERM,TPENMG,TPENLN) CALL REIO(WRRQ,TERM,EOTMG2,ETLN2) CALL REIO(RDRQ,TERM,IX,-1) CALL CLOSE(DCB) RCETFL = .TRUE. GO TO 409 GOTO 23091 23090 CONTINUE CALL RUNER(TERM,EOFFND,RECNO) CALL FCONT(DCB,IER,RWSTBY) CALL STALL(TYPE) CALL CLOSE (DCB) IF(.NOT.(LSTLU .NE. TERM))GOTO 23092 CALL LURQ(LUULK,LSTLU,1) 23092 CONTINUE RETURN 23091 CONTINUE 23088 CONTINUE IF(.NOT.(OPT .EQ. LIST))GOTO 23094 CALL RUNER(TERM,EOFFND,RECNO) CALL FCONT(DCB,IER,RWSTBY) CALL STALL(TYPE) CALL CLOSE(DCB) IF(.NOT.(LSTLU .NE. TERM))GOTO 23096 CALL LURQ(LUULK,LSTLU,1) 23096 CONTINUE RETURN 23094 CONTINUE GOTO 23087 23086 CONTINUE CALL RUNER(TERM,EOFFND,RECNO) CALL STALL(TYPE) CALL CLOSE(DCB) IF(.NOT.(LSTLU.NE.TERM))GOTO 23098 CALL LURQ(LUULK,LSTLU,1) 23098 CONTINUE RETURN 23087 CONTINUE C C check for corrupt record error C 23082 CONTINUE IF(.NOT. (.NOT.(LEN .GT. 0 .AND. LEN .EQ. INBUFR) .AND. LEN .NE. - *1))GOTO 23100 CALL RUNER(TERM,RCCRPT,RECNO) CALL STALL(TYPE) IF(.NOT.(OPT .EQ. ARCHIV))GOTO 23102 CALL EXEC(CTLRQ,WREOF+ARLU) 23102 CONTINUE IF(.NOT.(TYPE .EQ. UNIT))GOTO 23104 CALL FCONT(DCB,IER,RWSTBY) 23104 CONTINUE CALL CLOSE(DCB) IF(.NOT.(OPT .EQ. ARCHIV))GOTO 23106 CALL EXEC(CTLRQ,RWSTBY+ARLU) 23106 CONTINUE IF(.NOT.(LSTLU .NE. TERM))GOTO 23108 CALL LURQ(LUULK,LSTLU,1) 23108 CONTINUE RETURN C C check for monotonically increasing time stamps C 23100 CONTINUE IF(.NOT.(ZTIMEN .LT. ZTIMEO .OR. ZDATEN .LT. ZDATEO))GOTO 23110 CALL RUNER(TERM,BTIMST,RECNO) IF(.NOT.(OPT .EQ. ARCHIV))GOTO 23112 CALL EXEC(CTLRQ,WREOF+ARLU) 23112 CONTINUE CALL STALL(TYPE) IF(.NOT.(TYPE .EQ. UNIT))GOTO 23114 CALL FCONT(DCB,IER,RWSTBY) 23114 CONTINUE CALL CLOSE(DCB) IF(.NOT.(OPT .EQ. ARCHIV))GOTO 23116 CALL EXEC(CTLRQ,RWSTBY+ARLU) 23116 CONTINUE IF(.NOT.(LSTLU .NE. TERM))GOTO 23118 CALL LURQ(LUULK,LSTLU,1) 23118 CONTINUE RETURN C C check for READF error C 23110 CONTINUE IF(.NOT.(IER .LT. 0))GOTO 23120 CALL RUNER(TERM,RDFER,RECNO,IER) IF(.NOT.(OPT .EQ. ARCHIV))GOTO 23122 CALL EXEC(CTLRQ,WREOF+ARLU) 23122 CONTINUE CALL STALL(TYPE) IF(.NOT.(TYPE .EQ. UNIT))GOTO 23124 CALL FCONT(DCB,IER,RWSTBY) 23124 CONTINUE CALL CLOSE(DCB) IF(.NOT.(OPT .EQ. ARCHIV))GOTO 23126 CALL EXEC(CTLRQ,RWSTBY+ARLU) 23126 CONTINUE IF(.NOT.(LSTLU .NE. TERM))GOTO 23128 CALL LURQ(LUULK,LSTLU,1) 23128 CONTINUE RETURN 23120 CONTINUE END C C stall -- stall for operator intervention C SUBROUTINE STALL(TYPE), 92080-16584 REV. 2026 800428 IMPLICIT INTEGER(A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB LOGICAL YSORNO LOGICAL DONE LOGICAL DORMT DIMENSION MSBFR(15),ERRBF(12),MESCL(8),BF1(28),BF2(28),BF3(28) DATA MSBFR/2H ,2HDo,2H y,2Hou,2H w,2Han,2Ht ,2Hto,2H A,2HBO,2HRT, *2H (,2HY/,2HN),2H? / DATA ERRBF/2HOn,2Hly,2H ",2HY",2H o,2Hr ,2H"N,2H" ,2Hpl,2Hea,2Hse, *2H! / DATA BF1/2HXB,2HCL,2HS ,2HER,2HR#,2H x,2Hxx,2Hx ,2Hon,2H c,2Hlo,2H *se,2H o,2Hf ,2Hda,2Hta,2H b,2Has,2He ,2Hxx,2Hxx,2Hxx,2Hxx,2Hxx,2Hx *x,2Hxx,2Hxx,2Hxx/ DATA BF2/2H ,2H ,2H ,2H .,2H..,2Hin,2Hit,2Hia,2Hti,2Hng,2H e,2H *me,2Hrg,2Hen,2Hcy,2H d,2Hb ,2Hcl,2Hos,2He ,2Hpr,2Hoc,2Hed,2Hur,2He *.,2H..,2H ,2H / DATA BF3/2HPl,2Hea,2Hse,2H r,2Hes,2Hpo,2Hnd,2H c,2Hor,2Hre,2Hct,2H *ly,2H t,2Ho ,2Hth,2He ,2Hpr,2Hom,2Hpt,2Hs!,2H ,2H ,2H ,2H ,2H * ,2H ,2H ,2H / DATA MESCL/2HRU,2H, ,2HXX,2HXX,2HXX,2HIH,2H,,,2H,1/ DATA MSLN/15/ DATA ERLN/12/ DATA ENDTB/71/ DATA NAMLN/10/ DATA MESLN/16/ YSORNO = .FALSE. CONTINUE 23130 IF(.NOT. (.NOT.YSORNO))GOTO 23131 CALL EXEC(WRRQ,2400B+TERM,MSBFR,MSLN) CALL REIO(RDRQ,400B+TERM,IZ,-1) IZ = IALF2(IGET1(IZ,1)) YSORNO = IZ .EQ. YES .OR. IZ .EQ. NO IF(.NOT.(.NOT.YSORNO))GOTO 23132 CALL EXEC(WRRQ,TERM,BLANK,1) CALL EXEC(WRRQ,TERM,ERRBF,ERLN) CALL EXEC(WRRQ,TERM,BLANK,1) 23132 CONTINUE GOTO 23130 23131 CONTINUE DBN = 1 CONTINUE 23134 IF(.NOT. (DBN .LE. ENDTB))GOTO 23135 IF(.NOT. (INDBNO(DBN) .NE. -1))GOTO 23136 CALL XBCLS(INDBNO(DBN),DUMMY,1,STATUS) IF(.NOT. (STATUS .NE. 0))GOTO 23138 CALL JASC(STATUS,BF1,12,4) CALL MOVCA(INDBNO(DBN+1),1,BF1,39,18) CALL REIO(2,TERM,BLANK,1) CALL REIO(2,TERM,BLANK,1) CALL REIO(2,TERM,BF1,28) CALL REIO(2,TERM,BLANK,1) CALL WAIT(3) CALL REIO(2,TERM,BF2,28) CALL REIO(2,TERM,BF3,28) CALL REIO(2,TERM,BLANK,1) CALL MOVEW(INDBNO(DBN+1),MESCL(3),3) CALL LURQ(LUULK,TERM,1) IX = MESSS(MESCL,MESLN) DONE = .FALSE. CONTINUE 23140 IF(.NOT. (.NOT.DONE))GOTO 23141 DONE = DORMT(INDBNO(DBN+1)) GOTO 23140 23141 CONTINUE CALL LURQ(LULCK,TERM,1) 23138 CONTINUE INDBNO(DBN) = -1 CALL NUL(INDBNO(DBN+1),NAMLN-1) 23136 CONTINUE DBN = DBN+NAMLN GOTO 23134 23135 CONTINUE IF(.NOT. (IZ .EQ. YES))GOTO 23142 IF(.NOT. (OPT .EQ. ARCHIV))GOTO 23144 CALL EXEC(CTLRQ,RWSTBY+ARLU) 23144 CONTINUE IF(.NOT. (TYPE .EQ. UNIT .AND. OPT .NE. ARCHIV))GOTO 23146 CALL FCONT(DCB,IER,RWSTBY) 23146 CONTINUE CALL CLOSE (DCB) CALL RCABT 23142 CONTINUE RETURN END C C verfy -- archive function record verifier C SUBROUTINE VERFY(LU,TAPE,REC,BUF,LEN), 92080-16584 REV. 2026 800 *429 IMPLICIT INTEGER (A-Z) LOGICAL CMPW LOGICAL YSORNO DIMENSION IRBF(625),BUF(1) DATA VRFY/7/ CALL EXEC(3,200B+TAPE) CALL REIO(1,TAPE,IRBF,LEN) IF(.NOT.(.NOT.CMPW(IRBF,BUF,LEN)))GOTO 23148 CALL RUNER(LU,VRFY,REC) 23148 CONTINUE RETURN END C********************************************************* C********************************************************* C********************************************************* C C listr -- list request processor C SUBROUTINE LISTR(INLN,TYPE,INTYP,RECNO,CALLR) *, 92080-16584 REV. 2026 800312 IMPLICIT INTEGER (A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK DIMENSION OTBUF(36) DIMENSION RCTYP(2) DIMENSION UNLK(3),OPEN(3),CLOS(3),PUT(3),UPDT(3),DELT(3) DIMENSION PGHDR(40),TAPE(8),NAME(20),DATM(20),DBRC(32),RCLN(19) DIMENSION TSRC(23) LOGICAL JULIB LOGICAL OK DATA JDAWPT/6/ DATA YRWDPT/7/ DATA RLNWPT/8/ DATA HRWDPT/5/ DATA MNWDPT/4/ DATA SCWDPT/3/ DATA MSWDPT/2/ DATA LUWDPT/8/ DATA LINELN/8/ DATA OTBFLN/36/ DATA UNLK/-1,2HUN,2HLK/ DATA OPEN/0,2HOP,2HEN/ DATA CLOS/1,2HCL,2HS / DATA PUT/4,2HPU,2HT / DATA UPDT/5,2HUP,2HDT/ DATA DELT/6,2HDL,2HT / DATA RCTPWD/23/ DATA NAMWD/10/ DATA NAMLN/9/ DATA TSWDPT/12/ DATA PGHDR/2H1D,2H A,2H T,2H A,2H C,2H A,2H P,2H ,2H/ ,2H 1 * ,2H 0,2H 0,2H 0,2H ,2H D,2H A,2H T,2H A,2H ,2H B * ,2H A,2H S,2H E,2H ,2H R,2H E,2H C,2H O,2H V,2H E * ,2H R,2H Y,2H ,2H P,2H R,2H O,2H G,2H R,2H A,2H M */ DATA PGHDL/40/ DATA TAPE/2H ,2HRE,2HEL,2H #,2H ^,2H^^,2H^^,2H^ / DATA RLNMP/10/ DATA TMLN/8/ DATA NAME/2H L,2HOG,2H F,2HIL,2HE ,2HNA,2HMR,2H>>,2H ,2H^^,2H^^,2 *H^^,2H:^,2H^^,2H^^,2H^:,2H^^,2H^^,2H^^/ DATA NMPT/10/ DATA NMLN/20/ DATA SCPT/26/ DATA CRPT/33/ DATA DATM/2H ,2HDA,2HTE,2H: ,2H ^,2H^^,2H^/,2H^^,2H/^,2H^ ,2H T,2 *HIM,2HE:,2H ,2H^^,2H:^,2H^:,2H^^,2H.^,2H^ / DATA DTLN/20/ DATA YRBT/10/ DATA MOBT/15/ DATA DABT/18/ DATA HRBT/29/ DATA MNBT/32/ DATA SCBT/35/ DATA MSBT/38/ DATA RCLN/2H R,2HEC,2H #,2H ^,2H^^,2H^^,2H^ ,2H ,2HLE,2HNG,2HTH,2 *H =,2H ^,2H^^,2H^^,2H^ ,2HWO,2HRD,2HS / DATA RCBT/8/ DATA LNBT/26/ DATA LNRC/19/ DATA DBRC/2H ,2HDB,2H R,2HEC,2HOR,2HD ,2HTY,2HPE,2H: ,2H *,2H** * ,2H^^,2H^^,2H**,2H* ,2H ,2H F,2HOR,2H D,2HB ,2HNA, *2HMR ,2H ,2H^^,2H^^,2H^^,2H^^,2H^^,2H^^,2H^^,2H^^ *,2H^^/ DATA RCTY/12/ DATA DBNM/24/ DATA DBRCL/32/ DATA TSRC/2H ,2HTR,2HAN,2HSA,2HCT,2HIO,2HN ,2HRE,2HCO,2HRD,2H F,2 *HRO,2HM ,2HTS,2H# ,2H^^,2H^^,2H O,2HN ,2HLU,2H# ,2H^^,2H^ / DATA TSRL/23/ DATA TSWP/16/ DATA LUBT/42/ OK = JULIB(INBUFR(JDAWPT),INBUFR(YRWDPT),DAY,MONTH) IF(.NOT. (INTYP .EQ. HEADR))GOTO 23000 C C write the header on the list/audit device (if one was specified) C CALL REIO(WRRQ,LSTLU,PGHDR,PGHDL) CALL REIO(WRRQ,LSTLU,BLANK,1) REELNO = -INBUFR(RLNWPT) IF(.NOT. (TYPE .EQ. UNIT))GOTO 23002 CALL JASC(REELNO,TAPE,RLNMP,6) CALL REIO(WRRQ,LSTLU,TAPE,TMLN) GOTO 23003 23002 CONTINUE CALL MOVEW(FILENM,NAME(NMPT),3) CALL JASC(SECCD,NAME,SCPT,6) CALL JASC(CTRFNO,NAME,CRPT,6) CALL REIO(WRRQ,LSTLU,NAME,NMLN) 23003 CONTINUE CALL REIO(WRRQ,LSTLU,BLANK,1) CALL REIO(WRRQ,LSTLU,BLANK,1) CALL JASC(INBUFR(YRWDPT),DATM,YRBT,4) CALL JASC(MONTH,DATM,MOBT,2) CALL JASC(DAY,DATM,DABT,2) CALL JASC(INBUFR(HRWDPT),DATM,HRBT,2) CALL JASC(INBUFR(MNWDPT),DATM,MNBT,2) CALL JASC(INBUFR(SCWDPT),DATM,SCBT,2) CALL JASC(INBUFR(MSWDPT),DATM,MSBT,2) CALL REIO(WRRQ,LSTLU,DATM,DTLN) CALL REIO(WRRQ,LSTLU,1H1,-1) RETURN GOTO 23001 23000 CONTINUE CALL JASC(RECNO,RCLN,RCBT,6) CALL JASC(INLN,RCLN,LNBT,6) CALL REIO(WRRQ,LSTLU,RCLN,LNRC) IF(.NOT. (INBUFR(LUWDPT) .EQ. 0))GOTO 23004 IF(.NOT.(INBUFR(RCTPWD) .EQ. UNLK))GOTO 23006 CALL MOVEW (UNLK(2),DBRC(RCTY),2) 23006 CONTINUE IF(.NOT.(INBUFR(RCTPWD) .EQ. OPEN))GOTO 23008 CALL MOVEW (OPEN(2),DBRC(RCTY),2) 23008 CONTINUE IF(.NOT.(INBUFR(RCTPWD) .EQ. CLOS))GOTO 23010 CALL MOVEW (CLOS(2),DBRC(RCTY),2) 23010 CONTINUE IF(.NOT.(INBUFR(RCTPWD) .EQ. PUT))GOTO 23012 CALL MOVEW (PUT(2),DBRC(RCTY),2) 23012 CONTINUE IF(.NOT.(INBUFR(RCTPWD) .EQ. UPDT))GOTO 23014 CALL MOVEW (UPDT(2),DBRC(RCTY),2) 23014 CONTINUE IF(.NOT.(INBUFR(RCTPWD) .EQ. DELT))GOTO 23016 CALL MOVEW (DELT(2),DBRC(RCTY),2) 23016 CONTINUE CALL MOVEW(INBUFR(NAMWD),DBRC(DBNM),NAMLN) CALL REIO(WRRQ,LSTLU,DBRC,DBRCL) GOTO 23005 23004 CONTINUE CALL MOVEW(INBUFR(TSWDPT),TSRC(TSWP),2) CALL JASC(INBUFR(LUWDPT),TSRC,LUBT,4) CALL REIO(WRRQ,LSTLU,TSRC,TSRL) 23005 CONTINUE CALL JASC(INBUFR(YRWDPT),DATM,YRBT,4) CALL JASC(MONTH,DATM,MOBT,2) CALL JASC(DAY,DATM,DABT,2) CALL JASC(INBUFR(HRWDPT),DATM,HRBT,2) CALL JASC(INBUFR(MNWDPT),DATM,MNBT,2) CALL JASC(INBUFR(SCWDPT),DATM,SCBT,2) CALL JASC(INBUFR(MSWDPT),DATM,MSBT,2) CALL REIO(WRRQ,LSTLU,DATM,DTLN) CALL REIO(WRRQ,LSTLU,BLANK,1) 23001 CONTINUE IF(.NOT.(CALLR .EQ. TAPHN))GOTO 23018 J = INLN/LINELN LINECT = 1 NLINES = J*LINELN CONTINUE 23020 IF(.NOT. (LINECT .LE. NLINES))GOTO 23021 INADR=GTADR(INBUFR(LINECT)) CALL RPACK(LINELN,INADR,OTBUF) CALL REIO(WRRQ,LSTLU,OTBUF,OTBFLN) LINECT = LINECT + LINELN C C take care of last line if less than 8 words C GOTO 23020 23021 CONTINUE J = MOD(INLN,LINELN) IF(.NOT.(J .GT. 0))GOTO 23022 INADR = GTADR(INBUFR(LINECT)) CALL RPACK(J,INADR,OTBUF) CALL REIO(WRRQ,LSTLU,OTBUF,OTBFLN) 23022 CONTINUE CALL EXEC(WRRQ,LSTLU,BLANK,1) CALL EXEC(WRRQ,LSTLU,BLANK,1) 23018 CONTINUE RETURN END C********************************************************* C********************************************************* C********************************************************* C C recvr -- recovery request processor C SUBROUTINE RECVR(INLN,FLTYP,RCTYP,RECN) *, 92080-16584 REV. 2026 800501 IMPLICIT INTEGER (A-Z) C C GLOBAL CONSTANTS C COMMON /RCGLB/MAXLU,SC0LN ,SC1LN,SC2LN,SC36LN,S *C4LN,SC57LN ,ARCHIV,LIST,PRGE ,RECOVR,TERMNT,BL *ANK ,GONE,LOCKED,MTDVNO,MXRCLN * ,FILE,UNIT,COMP,PART,YES,NO,NOERCH,RDRQ,WRRQ *,CTLRQ,HEADR,RECRD,THRU,AFTER,INCL,NTINCL ,SCCK *WD,SGNBIT,RWND,RWSTBY,WREOF,ERASE,TAPHN ,RCV,LUL *CK,LUULK,TMPTYP C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB C C NOTE: ERROR CODES C COMMON /RCERR/ ANSEXP ,ILLANS,NUMFLD,BADLU,B *DFLNM,BDCRNO,BDSC,NOTFND ,ARDNMT,OPENER,CRNMT *D,WRNGSC,BDLST,FLLCKD ,NOFLLU,PURGER,TMSTBK,N *TSFBK,TTSFBK,INCTST ,DATERR,HRERR,MINERR,SECE *RR,MSCERR,DT1DT2,TM1TM2 ,NTDCP,FLDBLK DIMENSION SCPREP(3),XLMST(10) DIMENSION SKIPPD(15),ENDMG(7),MSG1(26),MSG2(29) DIMENSION MSG3(22),MSG4(26),MSG5(29),MSG6(20),MSG7(27),MSG8(18) DATA RCUNSN/9/ DATA RCTPWD/23/ DATA UNLK/-1/ DATA OPN/0/ DATA CLOS/1/ DATA ADD/4/ DATA UPDT/5/ DATA DELET/6/ DATA UNLOCK/2HUN/ DATA CNTINU/2HCO/ DATA NAMEWD/9/ DATA NAMELN/10/ DATA TSWDPT/8/ DATA SELF/0/ DATA QUIT/6/ DATA SAVRES/1/ DATA BELL/3407B/ DATA SCPRPL/3/ DATA LEVWPT/20/ DATA RECMOD/-3/ DATA DOPEN/150/ DATA STOR/1/ DATA GET/-1/ DATA DEL/0/ DATA SCPREP/015555B,015550B,015512B/ DATA SKIPPD/2H ,2H ,2H ,2H ,2H ,2H**,2H**,2H* ,2HSK,2HIP,2HPE *,2HD ,2H**,2H**,2H* / DATA SKIPLN/15/ DATA ENDMG/2H /,2HDC,2HRC,2HV ,2H: ,2H$E,2HND/ DATA ENDLN/7/ DATA MSG1/2HDB,2H u,2Hnl,2Hoc,2Hk ,2Hpe,2Hnd,2Hin,2Hg ,2Hfo,2Hr ,2 *Hda,2Hta,2H b,2Has,2He ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H * ,2H / DATA MS1PT/17/ DATA MS1LN/26/ DATA MSG2/2H d,2Ho ,2Hyo,2Hu ,2Hwi,2Hsh,2H t,2Ho ,2HUN,2HLO,2HCK,2 *H o,2Hr ,2Hig,2Hno,2Hre,2H t,2Hhe,2H u,2Hnl,2Hoc,2Hk ,2Han,2Hd ,2H *CO,2HNT,2HIN,2HUE,2H? / DATA MS2LN/29/ DATA MSG3/2H D,2HB ,2H--,2H> ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2 *H ,2H ,2H ,2H I,2HS ,2HNO,2HW ,2HCL,2HOS,2HED,2H!!/ DATA MS3PT/5/ DATA MS3LN/22/ DATA MSG4/2H ,2H ,2H A,2Hll,2H o,2Hth,2Her,2H c,2Hur,2Hre,2Hnt,2 *Hly,2H o,2Hpe,2Hn ,2Hda,2Hta,2H b,2Has,2Hes,2H a,2Hre,2H L,2HOC,2H *KE,2HD!/ DATA MS4LN/26/ DATA MSG5/2H ,2H ,2H T,2Hhe,2H l,2Hog,2H f,2Hil,2He ,2H< ,2HNA,2 *HMR,2H ,2H ,2H ,2H ,2H: ,2H ,2H ,2H: ,2H ,2H ,2H ,2H> ,2H *is,2H L,2HOC,2HKE,2HD!/ DATA M5FN/14/ DATA M5SC/34/ DATA M5CR/40/ DATA SCCRLN/5/ DATA MS5LN/29/ DATA MSG6/2H ,2H ,2H T,2Hhe,2H l,2Hog,2H f,2Hil,2He ,2H< ,2HLU,2 *H# ,2Hxx,2H >,2H i,2Hs ,2HLO,2HCK,2HED,2H! / DATA MS6PT/13/ DATA MS6LN/20/ DATA MSG7/2H ,2H T,2Hyp,2He ,2H"R,2HU,,2HDC,2HRC,2HV",2H t,2Ho ,2 *Hre,2Hst,2Har,2Ht ,2Hre,2Hco,2Hve,2Hry,2H. ,2H R,2Hec,2Hov,2Her,2H *y ,2Hwi,2Hll/ DATA MS7LN/27/ DATA MSG8/2H ,2H ,2Hco,2Hmm,2Hen,2Hce,2H f,2Hro,2Hm ,2Hth,2His,2 *H e,2Hxa,2Hct,2H p,2Hoi,2Hnt,2H. / DATA MS8LN/18/ C C write an audit entry on the audit device C CALL EXEC(WRRQ,LSTLU,BLANK,1) CALL EXEC(WRRQ,LSTLU,BLANK,1) CALL LISTR(INLN,FLTYP,RCTYP,RECN,RCV) IF(.NOT.(RCTYP .EQ. HEADR))GOTO 23000 RETURN C C do not process record if it is not a DB record C 23000 CONTINUE IF(.NOT.(INBUFR(TSWDPT) .GT. 0 ))GOTO 23002 CALL EXEC(WRRQ,LSTLU,SKIPPD,SKIPLN) RETURN C C process open record C 23002 CONTINUE IF(.NOT.(INBUFR(RCTPWD) .EQ. OPN))GOTO 23004 INBUFR(NAMEWD) = 0 CALL XBOPN(INBUFR(NAMEWD),INBUFR(LEVWPT),RECMOD,XLMST) IF(.NOT.(XLMST .NE. 0 .AND. XLMST .NE. DOPEN))GOTO 23006 CALL XLMER(TERM,XLMST,OPN,RECN) CALL STALL(FLTYP) 23006 CONTINUE IF(.NOT. (XLMST .EQ. 0))GOTO 23008 CALL DBTMG(STOR) 23008 CONTINUE C C process unlock record C 23004 CONTINUE ULKOP = 0 IF(.NOT. (INBUFR(RCTPWD) .EQ. UNLK))GOTO 23010 IF(.NOT.(LCKCHK .EQ. YES))GOTO 23012 CONTINUE 23014 IF(.NOT. (ULKOP .NE. UNLOCK .AND. ULKOP .NE. CNTINU))GOTO 23015 CALL MOVEW(INBUFR(NAMEWD+1),MSG1(MS1PT),NAMELN) CALL EXEC(WRRQ,TERM,MSG1,MS1LN) CALL EXEC(WRRQ,2400B+TERM,MSG2,MS2LN) CALL REIO(RDRQ,400B+TERM,ULKOP,1) IF(.NOT.(ULKOP .EQ. UNLOCK))GOTO 23016 C C do DB close C CALL DBTMG(GET) CALL XBCLS(INBUFR(NAMEWD),DUMMY,1,XLMST) IF(.NOT. (XLMST .NE. 0))GOTO 23018 CALL XLMER(TERM,XLMST,CLOS,RECN) CALL STALL(FLTYP) GOTO 23019 23018 CONTINUE CALL DBTMG(DEL) C C tell the user what's happening C 23019 CONTINUE CALL EXEC(WRRQ,TERM,SCPREP,SCPRPL) CALL EXEC(WRRQ,TERM,BELL,1) CALL MOVEW(INBUFR(NAMEWD+1),MSG3(MS3PT) * ,NAMELN) CALL EXEC(WRRQ,TERM,BLANK,1) CALL EXEC(WRRQ,TERM,BLANK,1) CALL EXEC(WRRQ,TERM,MSG3,MS3LN) CALL EXEC(WRRQ,TERM,BLANK,1) CALL EXEC(WRRQ,TERM,BLANK,1) IF(.NOT. (FLTYP .EQ. FILE))GOTO 23020 CALL MOVEW(FILENM,MSG5(M5FN),3) CALL JASC(SECCD,MSG5,M5SC,SCCRLN) CALL JASC(CTRFNO,MSG5,M5CR,SCCRLN) CALL EXEC(WRRQ,TERM,MSG5,MS5LN) GOTO 23021 23020 CONTINUE MSG6(MS6PT) = IASC(ARLU) CALL EXEC(WRRQ,TERM,MSG6,MS6LN) 23021 CONTINUE CALL EXEC(WRRQ,TERM,BLANK,1) CALL EXEC(WRRQ,TERM,BLANK,1) CALL EXEC(WRRQ,TERM,MSG7,MS7LN) CALL EXEC(WRRQ,TERM,MSG8,MS8LN) CALL EXEC(WRRQ,TERM,BLANK,1) CALL EXEC(WRRQ,TERM,BLANK,1) CALL EXEC(WRRQ,TERM,ENDMG,ENDLN) CALL EXEC(WRRQ,TERM,BLANK,1) CALL LURQ(LUULK,TERM,1) IF(.NOT.(LSTLU .NE. TERM))GOTO 23022 CALL LURQ(LUULK,LSTLU,1) C C terminate saving resources C 23022 CONTINUE CALL EXEC(QUIT,SELF,SAVRES) C C DCRCV will restart here C CALL LURQ(LULCK,TERM,1) IF(.NOT.(LSTLU .NE. TERM))GOTO 23024 CALL LURQ(LULCK,LSTLU,1) 23024 CONTINUE CALL RECSC(TERM,RCUNSN) C C open the DB just closed and lock it C C INBUFR(NAMEWD) = 0 CALL XBOPN(INBUFR(NAMEWD) * ,INBUFR(LEVWPT),RECMOD,XLMST) IF(.NOT.(XLMST .NE. 0))GOTO 23026 CALL XLMER(TERM,XLMST,OPN,RECN) CALL STALL(FLTYP) GOTO 23027 23026 CONTINUE CALL DBTMG(STOR) 23027 CONTINUE GOTO 23015 23016 CONTINUE IF(.NOT.(ULKOP .EQ. CONT))GOTO 23028 CALL REIO(WRRQ,LSTLU,BLANK,1) CALL REIO(WRRQ,LSTLU,SKIPPD,SKPLN) CALL REIO(WRRQ,LSTLU,BLANK,1) 23028 CONTINUE GOTO 23014 23015 CONTINUE 23012 CONTINUE C C process close record C 23010 CONTINUE IF(.NOT.(INBUFR(RCTPWD) .EQ. CLOS))GOTO 23030 CALL DBTMG(GET) CALL XBCLS(INBUFR(NAMEWD),DUMMY,1,XLMST) IF(.NOT.(XLMST .NE. 0))GOTO 23032 CALL XLMER(TERM,XLMST,CLOS,RECN) CALL STALL(FLTYP) GOTO 23033 23032 CONTINUE CALL DBTMG(DEL) 23033 CONTINUE C C process add, update, delete with 'XBSND' C 23030 CONTINUE IF(.NOT.(INBUFR(RCTPWD) .EQ. ADD .OR. INBUFR(RCTPWD) .EQ. UPDT .OR *. INBUFR(RCTPWD) .EQ. DELET))GOTO 23034 CALL DBTMG(GET) CALL XBSND(INBUFR(NAMEWD),INBUFR(RCTPWD),INLN-RCTPWD+1,XLMST) IF(.NOT.(XLMST .NE. 0))GOTO 23036 CALL XLMER(TERM,XLMST,INBUFR(RCTPWD),RECN) CALL STALL(FLTYP) 23036 CONTINUE C C gasp -- a DB record with an undefined function word!!!!! C 23034 CONTINUE IF(.NOT.(INBUFR(RCTPWD) .NE. OPN .AND. INBUFR(RCTPWD) .N *E. CLOS .AND. INBUFR(RCTPWD) .NE. UNLK .AND. I *NBUFR(RCTPWD) .NE. ADD .AND. INBUFR(RCTPWD) .NE. UPDT .A *ND. INBUFR(RCTPWD) .NE. DELET))GOTO 23038 CALL XLMER(TERM,-999,INBUFR(RCTPWD),RECN) CALL STALL(FLTYP) 23038 CONTINUE RETURN END C C dbtmg -- open db table manager C SUBROUTINE DBTMG(MGOPT), 92080-16584 REV. 2026 800425 IMPLICIT INTEGER(A-Z) C C GLOBAL VARIABLES C COMMON /RCLOC/ TERM ,OPT,LSTLU,RTNPT,FILENM(3 *),SECCD,CTRFNO,ARLU ,LCKCHK,FMPER(2),DCB(144) *,INBUFR(625),RECBF(2) ,INDBNO(80),NXTDB LOGICAL CMPW DATA NAMWD/9/ DATA NAMLN/10/ DATA ENDTB/71/ DATA STORE/1/ DATA DELET/0/ DATA RETREV/-1/ IF(.NOT.(MGOPT .EQ. STORE))GOTO 23040 CALL MOVEW(INBUFR(NAMWD),INDBNO(NXTDB),NAMLN) C C update next available pointer C DBN = 1 CONTINUE 23042 IF(.NOT. (DBN .LE. ENDTB))GOTO 23043 IF(.NOT.(INDBNO(DBN) .EQ. -1))GOTO 23044 NXTDB = DBN GOTO 23043 23044 CONTINUE DBN = DBN + NAMLN GOTO 23042 23043 CONTINUE 23040 CONTINUE IF(.NOT.(MGOPT .EQ. DELET .OR. MGOPT .EQ. RETREV))GOTO 23046 DBN = 2 CONTINUE 23048 IF(.NOT. (DBN .LE. ENDTB+1))GOTO 23049 IF(.NOT.(CMPW(INBUFR(NAMWD+1),INDBNO(DBN),NAMLN-1)))GOTO 23050 IF(.NOT.(MGOPT .EQ. DELET))GOTO 23052 INDBNO(DBN-1) = -1 CALL NUL(INDBNO(DBN),NAMLN-1) GOTO 23053 23052 CONTINUE INBUFR(NAMWD) = INDBNO(DBN-1) 23053 CONTINUE GOTO 23049 23050 CONTINUE DBN = DBN + NAMLN GOTO 23048 23049 CONTINUE 23046 CONTINUE RETURN END C C xlmer -- 'XMLIM' error processor C SUBROUTINE XLMER(DVC,IERR,IOPT,REC), 92080-16584 REV. 2026 80031 *0 IMPLICIT INTEGER(A-Z) DIMENSION MESGBF(27),UNDF(27) DATA MESGBF/6412B,2H ,2H/D,2HCR,2HCV,2H: ,15446B,2HdB * ,2H ,2Hxx,2Hxx,2Hxx,2H E,2HRR,2H# ,2Hyy,2Hyy * ,2H O,2HN ,2HRE,2HC#,2Hzz,2Hzz,2H !,15446B,2Hd@,6412B/ DATA UNDF/6412B,2H ,2H/D,2HCR,2HCV,2H: ,15546B,2HdB * ,2HUN,2HDE,2HFI,2HNE,2HD ,2HOP,2HER,2HAT,2HN * ,2H O,2HN ,2HRE,2HC#,2Hzz,2Hzz,2H !,15446B,2Hd@,6412B/ C C undefined operation?? C IF(.NOT.(IERR .EQ. -999))GOTO 23054 CALL JASC(REC,UNDF,43,4) CALL REIO(2,DVC,UNDF,27) RETURN C C XMLIM ERROR!! C 23054 CONTINUE CALL JASC(IERR,MESGBF,31,4) CALL JASC(REC,MESGBF,43,4) IF(.NOT.(IOPT .EQ. 0))GOTO 23056 CALL MOVEW(6H XBOPN,MESGBF(10),3) 23056 CONTINUE IF(.NOT.(IOPT .EQ. 1))GOTO 23058 CALL MOVEW(6H XBCLS,MESGBF(10),3) 23058 CONTINUE IF(.NOT.(IOPT .EQ. 4))GOTO 23060 CALL MOVEW(6H XBPUT,MESGBF(10),3) 23060 CONTINUE IF(.NOT.(IOPT .EQ. 5))GOTO 23062 CALL MOVEW(6H XBUPD,MESGBF(10),3) 23062 CONTINUE IF(.NOT.(IOPT .EQ. 6))GOTO 23064 CALL MOVEW(6H XBDEL,MESGBF(10),3) 23064 CONTINUE CALL REIO(2,DVC,MESGBF,27) RETURN END END$