 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$
                                                                                                                                                                                            