       SPL,L,O
!     NAME:   G1CDA 
!     SOURCE: 92067-18441 
!     RELOC:  92067-16425 
!     PGMR:   G.A.A.
! 
!  ***************************************************************
!  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     *
!  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
!  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
!  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
!  ***************************************************************
! 
       NAME G1CDA(8)"92067-16425 REV.2013 800102" 
! 
       LET G1OMS,                           \OUTPUT MESSAGE ROUTINE 
           G1CQQ,                           \EXPAND AN ERROR CODE 
           G1IMS,                           \PROMPT AND GET ANSWER
           G1CSD,                           \SHUT DOWN ROUTINE
           G1ZAP,                           \CLEAR A 16 WORD BUF. 
           G1RD,                            \READ RECORD FROM CURRENT FILE
           G1ERP,                           \ERROR PROCESS ROUTINE
           ISMVE,                           \SCB READ ROUTINE 
\ 
           PURGE,                           \FMP PURGE FILE ROUTINE 
           OPEN,                            \FMP OPEN ROUTINE 
           EXEC,                            \???? 
           RNRQ                             \ALLOCATE/RELEASE RN NUMBERS
                 BE SUBROUTINE,EXTERNAL 
! 
       LET .DFER,                           \MOVE THREE WORDS ROUTINE 
           G1PCR                            \ROUTINE TO SET $SPCR 
                 BE SUBROUTINE,EXTERNAL,DIRECT
! 
       LET KCVT                             \CONVERT TO 2 CHAR. ASCII 
                BE FUNCTION,EXTERNAL
! 
       LET  FERR                            \INTERNAL ERROR REPORTER
                  BE SUBROUTINE 
! 
       LET G0END,                           \"END GASP" 
           G0JBF,                           \"JOBFIL" 
           G0SPF,                           \"SPLCON" 
           G0DCB,                           \MASTER DCB 
           G0BUF,                           \16 WORD BUFFER IN MAIN 
           G0WD2,                           \WORD 2 OF G0BUF
           G0W14,                           \WORD 14 OF G0BUF 
           G0P1V,                           \VALUE OF 1'ST PRAM IN PARSE BUF
           G0SDN,                           \LOCAL SPOOL SHUT DOWN FLAG 
           G0JDN,                          \LOCAL JOB   SHUT DOWN FLAG
           G0NPR                           \NO PRINT FLAG 
                 BE INTEGER,EXTERNAL
! 
       LET RESON(8),MES(3)   BE INTEGER 
       INITIALIZE RESON TO 10,"ERROR ON FILE "
! 
       LET G0N8M BE INTEGER(20) 
       INITIALIZE G0N8M TO 19,"TRY DA AGAIN WHEN ABOVE FILE IS CLOSED"
       LET CLEAN(8) BE INTEGER
       INITIALIZE CLEAN TO 7,"SPOOL IS DEAD!" 
! 
       LET REALY(9) BE INTEGER
       INITIALIZE REALY TO 8,"KILL SPOOLING? _" 
! 
       LET SIZE,SIZE1  BE INTEGER           !DO NOT REARRANGE THESE 
       LET SPOL(2),SPLNO,IER,I  BE INTEGER  !TWO LINES
       INITIALIZE SPOL TO "SPOL"
       INITIALIZE SPLNO,IER TO 1,0
! 
       LET SEC BE CONSTANT(123456K)         !JOBFIL/SPLCON SECURITY CODE
       LET RLF BE CONSTANT(40040K)          !RN RELEASE CODE WORD 
! 
G1CDA: SUBROUTINE(F) GLOBAL 
! 
! IF F = -1 OR -2 THEN COMING FROM INITIALIZE 
! F = -1 IF O.K. TO SHUT DOWN 
! F = -2 IF SHUT DOWN NOT O.K. BECAUSE SPLCON DOES NOT EXIST OR NOT OPENED
! 
       ASSEMBLE["EXT $SMID";"XLA $SMID";"STA SMID";\GET SESSION ID
                "EXT $DSCS";"XLA $DSCS";"STA DSCS"]!GET SESSION IS FLAG 
       IF DSCS < 0 THEN GO TO INIT          !IF NOT SESSON THEN GO INITIALIZE 
       CALL ISMVE($($1717K+32),SMID,USID,1) !GET USER ID WORD 
       IF USID = 7777K THEN GO TO INIT      !ALLOW ONLY SYSTEM MGR. HERE
       IER _ 46                             !FAILED TEST  SET UP ERROR
       CALL G1CQQ(SIZE)                     !SEND IT AND
       G0NPR _ "NP"                         !SET THE NO PRINT FLAG
       CALL G1ERP(IER)                      !POST ERROR IN SCB AND
       RETURN                               !BAIL OUT!
! 
INIT:  IF (F = -1 OR F = -2) THEN GO TO SHTDN !IF FROM INIT SKIP QUERY
       CALL G1IMS(REALY)                    !MAKE SURE
       IF G0P1V # "YE" THEN RETURN          !IF A MISTAKE THEN RETURN 
! 
!      FIRST CALL SHUT DOWN 
! 
SHTDN: IF F = -2 THEN GO TO DOWN            !SPLCON NOT OPENED OR CREATED 
       IF G0JDN THEN[IF G0SDN THEN GO TO DOWN]
       IER _ 0
       CALL G1CSD(SIZE1)
! 
!      FIRST GET THE NUMBER OF SPOOL POOL FILES TO PURGE
! 
DOWN:  ASSEMBLE["XLA $SPCR";"EXT $SPCR";"STA SPCR"]! GET $SPCR
       CALL G1PCR(0)                        !ZAP $SPCR
       CALL OPEN(G0DCB,IER,G0SPF,0,SEC,SPCR) !TRY TO GET THE SPOOL CONTROL
       IF IER = -8 THEN [                   \IF NOT AVAILABLE THEN
          CALL FERR(G0SPF);                 \REPORT IT AS SUCH AND
          GO TO EXX]                        !DO A REAL EXIT 
       CALL G1ZAP(G0DCB)                    !ZAP THE DCB TO HOLD THE OPEN 
       CALL OPEN(G0DCB,IER,G0JBF,0,SEC,SPCR)!OPEN JOB FILE
       IF IER = -8 THEN[                    \IF JOBFIL NOT AVAILABLE
          CALL FERR(G0JBF);                 \REPORT THE PROBLEM 
          GO TO EXX]                        !AND GO EXIT
       IF IER = 2 THEN GO TO RD17           !IF NO ERROR JUMP 
       IF IER = -6 THEN[SPNO_80;GO TO GOTNO]!IF NO FILE PURGE 80
       CALL G1PCR(-SPCR)                    !RESET $SPCR WE FAILED SOME HOW 
       IF IER = -32 THEN IER _ 54           !CHANGE REPORT IF DISC NOT MOUNTED
! 
       CALL FERR(G0JBF)                     !REPORT ANY OTHER ERROR 
       GO TO EX                               !AND GET OUT
! 
! 
RD17:  CALL G1RD(G0BUF,17)                  !GET RECORD 17
       CALL G1ZAP(G0DCB)                    !ZAP DCB TO KEEP FILE OPEN
       SPNO_G0WD2 AND 177K                  !SET THE COUNT
       IF SPNO > 80 THEN SPNO _ 80          !MAX # OF SPOOL FILES 
       RN1_G0BUF                            !CAPTURE THE RN NUMBERS 
       RN2_G0W14                            !CAPTURE THE RN NUMBERS 
! 
GOTNO: FOR I_1 TO SPNO DO THRU X
          SPLNO_KCVT(I) 
          IF SPLNO < 30000K THEN SPLNO_SPLNO OR 30000K !FIX IF 01-09
          CALL PURGE(G0DCB,IER,SPOL,SEC)    !PURGE THE FILE 
          IF IER > -1 THEN GO TO X
          IF IER = -6 THEN GO TO X          !IF NO FILE OR NO ERROR 
          CALL FERR(SPOL)                   !DON'T WORRY, ELSE REPORT 
          GO TO EX                            !AND STOP 
X:                                          !END OF LOOP
! 
       CALL RNRQ(RLF,RN1,IS)                !RELEASE THE TWO RN'S 
       GO TO NEX1 
! 
NEX1:  CALL RNRQ(RLF,RN2,IS)
       GO TO NEX2 
! 
NEX2:  CALL PURGE(G0DCB,IER,G0JBF,SEC,SPCR)   !PURGE JOB FILE 
       IF IER < 0 THEN CALL FERR(G0JBF)     !REPORT ERRORS
! 
       CALL OPEN(G0DCB,IER,G0SPF,0,SEC,SPCR)!NOW GET SPLCON 
       IF IER #2 THEN[                      \IF ERROR REPORT IT 
Z:     CALL FERR(G0SPF);GO TO EX]             !AND EXIT 
! 
       CALL G1RD(G0BUF,1)                   !GET THE FIRST RECORD 
       CALL G1ZAP(G0DCB)                    !DON'T LET PURGE CLOSE FILE 
       CALL RNRQ(RLF,G0BUF,IS)              !RELEASE THE RN.
       GO TO NEX3 
! 
NEX3:  CALL PURGE(G0DCB,IER,G0SPF,SEC,SPCR) !PURGE THE FILE 
       IF IER < 0 THEN GO TO Z              !IF ERROR REPORT IT 
       CALL G1OMS(CLEAN)                    !ELSE REPORT DONE 
EX:    IF (F = -1 OR F = -2) THEN [         \IF CALLED FROM INIT. RETURN
          IF IER # 54 THEN RETURN]          !IF DISCS WERE FOUND
EX2:   CALL G1OMS(G0END)                    !ELSE EXIT
       CALL EXEC(6) 
! 
EXX:   CALL G1OMS(G0N8M)                    !SEND THE -8 LINE 
       CALL G1PCR(-SPCR)                    !RESET THE SPOOL CR # 
       GO TO EX2                            !AND EXIT 
! 
       END
! 
! 
FERR:  SUBROUTINE(N)
       CALL .DFER(MES,N)                    !SET UP THE FILE NAME 
       CALL G1OMS(RESON)                    !SENT IT
       CALL G1CQQ(SIZE)                     !CALL ?? TO SEND FULL MESSAGE 
       G0NPR _ "NP"                         !SET THE NO PRINT FLAG
       CALL G1ERP(IER)                      !POST ERROR TO THE SCB
       RETURN 
       END
       END
       END$ 
                                                                                                                                                                                                                                                              