FTN4 C C C C *************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * C * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* C * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C *************************************************************** C C C NAME: CLOAD C SOURCE: 92067-18358 C RELOC: 92067-16358 C PGMR: C.M.M. C C C THE CLOAD PROGRAM IS A FRIENDLY INTERFACE TO ALL SUPPORTED C HP-1000 SYSTEM LANGUAGES. C IT PROVIDES THE FUNCTIONS OF ID SEGMENT MANAGEMENT, SPOOL C LU MANAGEMENT, SCHEDULING OF THE DESIRED LANGUAGE, AND C INVOCATION OF THE LOADR TO LINK THE PROGRAM TO WHATEVER C OTHER MODULES IT REQUIRES. C C C C C PROGRAM CLOAD (3,90),92067-16358 REV.1903 790503 DIMENSION IBUF(60),IXBF(60),IPROG(3,11),IREG(2),IWARN1(22) DIMENSION IDCB1(144),SPMSG(10),ISPOOL(16),IPROCD(21) DIMENSION IPBUF(120),IPRMT(16),INAME(3),IRTN(5),ISMP(3) DIMENSION IMOUNT(28),IFULL(17),IFMERR(23),ISPCN(3) DIMENSION IM5010(18),IM5040(16),IM5070(15),IM5080(17) DIMENSION IM5090(20),IM5110(20),IM5130(16),IM5230(18) DIMENSION IM5240(17),IM5250(18),IFMGR(12),IDONE(6) DIMENSION ILOADR(20),ILOAD(3),ILOAD4(3),IPRLD(16) DIMENSION IXREF(3),IM6260(19),IM5260(10),INFORM(15) C LOGICAL IFTTY INTEGER GETSP,SPMSG DOUBLE PRECISION XPROG(9) EQUIVALENCE (REG,IREG,IA),(IREG(2),IB) EQUIVALENCE (IPROG,XPROG) C C THE FOLLOWING ARE THE PROGRAMS THAT WE CAN TALK TO C IF YOU WANT ANOTHER PROGRAM JUST ADD IT TO THE LIST C AND INCREASE THE LENGTH OF THE IPROG DIMENSION. C DATA ISPOOL/0,0,2HCO,2HMP,2H00,0,0,0,400B,99,0,0,0,0,0,0/ C DATA INFORM/2H/C,2HLO,2HAD,2H: , & 2HIN,2HFO,2HRM,2H S,2HYS,2HTE,2HM ,2HMA,2HNA, & 2HGE,2HR./ C C DATA ISMP/2HSM,2HP ,2H / DATA IXREF/2HXR,2HEF,2H / DATA ISPCN/2HSP,2HLC,2HON/ C DATA IWARN1/2H/C,2HLO,2HAD,2H: , &2HWA,2HRN,2HIN,2HG,,2H ,2HSP,2HOO,2HL ,2HDI,2HSC,2H I,2HS , &2HGE,2HTT,2HIN,2HG ,2HFU,2HLL/ C DATA IPROCD/2H/C,2HLO,2HAD,2H: , &2HCO,2HMP,2HIL,2HAT,2HIO,2HN ,2HIS,2H P,2HRO,2HCE,2HED,2HIN,2HG , &2HNO,2HRM,2HAL,2HLY/ C DATA IPRLD/2H/C,2HLO,2HAD,2H: , &2HLO,2HAD,2H P,2HRO,2HCE,2HED,2HIN,2HG ,2HNO,2HRM,2HAL,2HLY/ DATA IMOUNT/2H/C,2HLO,2HAD,2H: ,2HWA,2HRN,2HIN,2HG,,2H , &2HSP,2HOO,2HL ,2HDI,2HSC,2H N,2HOT,2H M,2HOU,2HNT,2HED , &2H T,2HO ,2HTH,2HIS,2H S,2HES,2HSI,2HON/ C DATA IFULL /2H/C,2HLO,2HAD,2H: ,2HWA,2HRN,2HIN,2HG,,2H , &2HSP,2HOO,2HL ,2HDI,2HSC,2H F,2HUL,2HL / C DATA IFMERR/2H/C,2HLO,2HAD,2H: , &2HFM,2HGR,2H-0,2HXX,2H ,2H ,2HER,2HRO,2HR ,2HON,2H S,2HPO, &2HOL,2H F,2HIL,2HE ,2HCR,2HEA,2HT / C DATA IM5010/2H/C,2HLO,2HAD,2H: , &2HSO,2HUR,2HCE,2H I,2HNP,2HUT,2H M,2HUS,2HT ,2HBE,2H A,2H F, &2HIL,2HE / C DATA IM5040/2H/C,2HLO,2HAD,2H: , &2HSO,2HUR,2HCE,2H F,2HIL,2HE ,2HOP,2HEN,2H ,2HER,2HRO,2HR / C DATA IM5070/2H/C,2HLO,2HAD,2H: , &2HUN,2HRE,2HCO,2HGN,2HIZ,2HED,2H L,2HAN,2HGU,2HAG,2HE / C DATA IM5080/2H/C,2HLO,2HAD,2H: , &2HLA,2HNG,2HUA,2HGE,2H S,2HCH,2HED,2HUL,2HIN,2HG ,2HER,2HRO,2HR / C DATA IM5090/2H/C,2HLO,2HAD,2H: , &2H ,2H ,2H ,2HNO,2HT ,2HLO,2HAD,2HED,2H O,2HN ,2HTH,2HIS, &2H S,2HYS,2HTE,2HM / C DATA IM5110/2H/C,2HLO,2HAD,2H: , &2HCL,2HOS,2HE ,2HER,2HRO,2HR ,2HON,2H ',2HRP,2H' ,2HOF,2H L, &2HAN,2HGU,2HAG,2HE / C DATA IM5130/2H/C,2HLO,2HAD,2H: , &2HMO,2HRE,2H T,2HHA,2HN ,2H80,2H S,2HPO,2HOL,2H F,2HIL,2HES/ C DATA IFMGR/2H/C,2HLO,2HAD,2H: ,2HFM,2HGR,2H-0,2HXX,2H , &2HER,2HRO,2HR / C DATA IM5230/2H/C,2HLO,2HAD,2H: , &2HCO,2HMP,2HIL,2HER,2H A,2HBO,2HRT,2HED,2H A,2HBN,2HOR,2HMA,2HLL, &2HY / C DATA IM5240/2H/C,2HLO,2HAD,2H: , &2HSY,2HST,2HEM,2H O,2HUT,2H O,2HF ,2HID,2H S,2HEG,2HME,2HNT,2HS / C DATA IM5250/2H/C,2HLO,2HAD,2H: , &2HCO,2HMP,2HIL,2HER,2H P,2HAS,2HSE,2HD ,2HBA,2HCK,2H E,2HRR,2HOR, &2HS / C DATA IM5260/2H/C,2HLO,2HAD,2H: , &2HIN,2HPU,2HT ,2HER,2HRO,2HR./ C DATA IM6260/2H/C,2HLO,2HAD,2H: , &2HLI,2HST,2H D,2HEV,2HIC,2HE ,2HMU,2HST,2H N,2HOT,2H B,2HE , &2HA ,2HFI,2HLE/ C DATA IDONE/2H/C,2HLO,2HAD,2H: ,2HEN,2HD / DATA ISIZE/24/ DATA MLEN/20/ C DATA IOPT/2HR / C DATA SPMSG/2HSP,2HOO,2HL ,2HFI,2HLE,2H =,2H ,2H ,2H ,2H / C DATA IPROG/2HFT,2HN4,2H , & 2H$P,2HAS,2HCA, & 2HAS,2HMB,2H , & 2HCO,2HBO,2HL , & 2HMI,2HCR,2HO , & 2HRP,2HG ,2H , & 2HSP,2HL ,2H , & 2HHP,2HAL,2H , & 2HAL,2HGO,2HL , & 2HPA,2HSC,2HL , & 2HSN,2HOB,2HL / C C DATA IBUF/2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , & 2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , & 2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , & 2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , & 2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , & 2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H / C C DATA IXBF/2H,,,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , & 2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , & 2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , & 2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , & 2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , & 2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H / C DATA IPRMT/ 2HNA,2HMR,2H(S,2H),, & 2HNA,2HMR,2H(L,2H),, & 2HNA,2HMR,2H(R,2H),, & 2H/ C DATA ILOADR/2H ,,2H,,,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , &2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H / DATA ILOAD/2HLO,40400B/ DATA ILOAD4/2HLO,2HAD,2HR / C C IKVT(IERR) = 2H00 + (IERR/10*256) + MOD(IERR,10) C C C C C C C GET THE LU OF OUR TERMINAL & PICK UP THE SCHEDULING STRING C LU = LOGLU(LU) CALL LUTRU(LU,LUX) ISPOOL(4) = IKVT(LUX) LU = LU + 400B REG= EXEC(14,1,IBUF,-120) IF(IA.EQ.1) GO TO 175 LENGTH = IB ISTRC = 1 C C PARSE TWICE & THROW AWAY (DON'T NEED THE ' RU,CLOAD ' ) C CALL NAMR(IPBUF,IBUF,LENGTH,ISTRC) CALL NAMR(IPBUF,IBUF,LENGTH,ISTRC) C C PARSE AS MANY TIMES AS REQUIRED C 25 DO 100 KOUNT = 0,9 IPBUF(11+KOUNT*11) = ISTRC IA = NAMR(IPBUF(1 + 11*KOUNT),IBUF,LENGTH,ISTRC) IF (IA .LT. 0) GO TO 150 100 CONTINUE C C KOUNT = 0 IF RU,CLOAD C KOUNT = 1 IF RU,CLOAD,SORC C KOUNT = 2 IF RU,CLOAD,SORC,LIST C KOUNT = 3 IF RU,CLOAD,SORC,LIST,RELO C KOUNT = 4 IF RU,CLOAD,SORC,LIST,RELO,LANG C KOUNT = 5 IF RU,CLOAD,SORC,LIST,RELO,LANG,A C KOUNT = 6 IF RU,CLOAD,SORC,LIST,RELO,LANG,A,B C KOUNT = 7 IF RU,CLOAD,SORC,LIST,RELO,LANG,A,B,C C KOUNT = 8 IF RU,CLOAD,SORC,LIST,RELO,LANG,A,B,C,D C KOUNT = 9 IF RU,CLOAD,SORC,LIST,RELO,LANG,A,B,C,D,E C KOUNT = 10 IF RU,CLOAD,SORC,LIST,RELO,LANG,A,B,C,D,E,F C C C SOURCE IN IPBUF( 1) - IPBUF( 11) C LIST IN IPBUF( 12) - IPBUF( 22) C RELO IN IPBUF( 23) - IPBUF( 33) C LANG IN IPBUF( 34) - IPBUF( 44) C OPT PR IN IPBUF( 45) - IPBUF( 55) C OPT PR IN IPBUF( 56) - IPBUF( 66) C OPT PR IN IPBUF( 67) - IPBUF( 77) C OPT PR IN IPBUF( 78) - IPBUF( 88) C OPT PR IN IPBUF( 89) - IPBUF( 99) C OPT PR IN IPBUF(100) - IPBUF(110) C NULL IN IPBUF(111) - IPBUF(120) C C C AT THIS POINT THE ENTIRE INPUT BUFFER HAS BEEN PARSED. C IPBUF BUFFER IS SET UP AS 11 WORDS FOR EACH ENTRY C WORDS 1-10 ARE THE OUTPUT OF NAMR. THE 11 WORD IS C THE CHAR # OF WHERE THE STRING STARTS. C C C NOW CHECK 1ST PARAMETER TO SEE IF NULL OR AN LU C IF A NAMR THEN NO PROMPT IS REQUIRED C 150 IF(IAND(IPBUF(4),3).EQ.3) GO TO 200 C C FIRST PARAMETER IS AN LU OR NOT SUPPLIED SO PROMPT C FOR ADDITIONAL INPUT. BUT MAKE SURE WE DO THIS ONLY ONCE. C IF (IPBUF(11) .EQ. 1) GO TO 5005 175 CALL EXEC(2,LU,IPRMT,16) REG = REIO(1,LU,IBUF,-120) ISTRC = 1 LENGTH = IB GO TO 25 C C C OK SO NOW WE HAVE A NAMR. INITIALIZE THE STRING PUSHERS AND C PUSH THE NAMR INTO THE DESTINATION BUFFER. C LENGTH IS THE LENGTH OF THE SOURCE STRING AND EVERY 11TH WORD C IN THE IPBUF BUFFER HAS THE START CHAR COUNT FOR THAT NAMR. C C 200 NCHRS = 2 CALL SETSB(IBUF,ISCH,-120) CALL SETDB(IXBF,NCHRS) C CALL INAMR(IPBUF,IXBF,120,NCHRS) C C************************************************************************** C* FINISHED WITH SOURCE NAMR NOW GET LIST NAMR * C************************************************************************** C C C CHECK FOR COMPILER LIBRARY DEFAULT C IF(IOR(IAND(IPBUF(12),77600B),40B).EQ.2H- ) GO TO 320 LTYPE = IAND(IPBUF(15),3) IF (LTYPE .EQ. 3) GO TO 6260 C C LIST NAMR IS AN LU OR NULL C IF (LTYPE .EQ. 1) GO TO 350 C C NO LU OR NULL LU C 320 IPBUF(15) = 1 IPBUF(12) = LU - 400B C C PUSH LIST LU INTO STRING C GO TO 399 C C IF NO SPOOLING IN SYSTEM OR C IF HE DOESN'T WANT SPOOLING OR C IF SPECIFIED LU = A TTY , THEN DON'T SPOOL ANYTHING ! C 350 ISPOOL(7) = GETSP(IDUMY) IF (ISPOOL(7) .GE. 0) GO TO 399 IF (IFTTY(IPBUF(12))) GO TO 399 IF(IPBUF(12) .EQ. 0) GO TO 399 IF (IPBUF(16).EQ.2HNS) GO TO 399 C C OK SO SPOOLING EXISTS IN THE SYSTEM C AND AN LU WAS SPECIFIED . SO CREATE A FILE & CALL SMP C TO USE IT AS A SPOOL FILE. SMP WILL TELL US WHETHER C THE SPECIFIED LU IS OK FOR SPOOLING. IF IT TURNS OUT C THAT THE LU IS NOT FOR SPOOLING THEN WE WILL HAVE TO C PURGE THAT FILE AND JUST SEND THE OUTPUT TO THE LU C NORMALLY. C C ISPOOL(16) = IPBUF(12) C IF((IPBUF(12).GT.64) .OR. (IPBUF(12) .LT. 0)) GO TO 5260 IF(LUTRU(IPBUF(12),IA) .LT. 0) GO TO 5260 CALL EXEC(13,IPBUF(12),ISTATS) 360 ISPOOL(8) = IAND(ISTATS,37400B)/256 C C NOW SEE IF THE SPOOL DISC IS MOUNTED C CALL FSTAT(IDCB1) DO 365 I = 1,120,4 IF(ISPOOL(7) .EQ. - IDCB1(I)) GO TO 370 365 CONTINUE 366 CALL EXEC(2,LU,IMOUNT,MLEN) 367 CALL EXEC(2,LU,IPROCD,21) GO TO 399 C C OK, ITS MOUNTED BUT IS IT GETTING TO BE FULL. IF HE ONLY C HAS A FEW MORE TRACKS LEFT WE'LL WARN HIM. BOY THIS IS C IS SO FRIENDLY IT'S PATERNALISTIC. C 370 MLEN = 28 IFMP = IDCB1(I+1) CALL EXEC(1,IDCB1(I),IDCB1,128,IFMP,0) IF(IDCB1(8) - IDCB1(10) .GT. 40) GO TO 372 C C ONLY A FEW MORE TRACKS LEFT ON THE SPOOL DISC C SO WARN HIM TO CLEAN UP HIS ACT C 7000 CALL EXEC(2,LU,IWARN1,22) CALL EXEC(2,LU,INFORM,15) CALL EXEC(2,LU,IPROCD,21) C C OK, EITHOR ITS FULL OR THERE IS ROOM SO LETS CREATE C A FILE & SEE. C 372 DO 375 I = 1,80 ISPOOL(5) = IKVT(I) CALL CREAT(IDCB1,IER,ISPOOL(3),ISIZE,3,ISPOOL(6),ISPOOL(7)) IF(IER .EQ. -2) GO TO 375 IF(IER .EQ. -18) GO TO 366 IF((IER .NE. -6).AND.(IER .NE. -19)) GO TO 373 7001 CALL EXEC(2,LU,IFULL,17) GO TO 367 C 373 IF(IER .LT. 0) GO TO 5020 CALL CLOSE(IDCB1,IER) GO TO 389 375 CONTINUE GO TO 5130 C C C **************************** C * GET THE SPOOL LU !!!! * C **************************** C C 389 CALL SPOPN(ISPOOL,ISLU) IF (ISLU .GT. 0) GO TO 390 C C UNSUCCESSFUL SPOOL OPEN MUST NOT HAVE BEEN A SPOOL LU C SO CLEAN UP THE MESS WE JUST CAUSED C CALL PURGE(IDCB1,IERR,ISPOOL(3),ISPOOL(6),ISPOOL(7)) GO TO 399 C 390 IPBUF(12) = ISLU C SPMSG(8) = ISPOOL(3) SPMSG(9) = ISPOOL(4) SPMSG(10) = ISPOOL(5) CALL REIO(2,LU,SPMSG,10) C 399 CALL INAMR(IPBUF(12),IXBF,120,NCHRS) C C C C C************************************************************************ C* NOW CHECK OUT THE RELO NAMR * C************************************************************************ C C 400 IRELO = IAND(IPBUF(26),3) IF((IRELO.EQ.3).OR.(IRELO .EQ. 1)) GO TO 425 IF (IOR(IAND(IPBUF,77400B),40B).NE.2H& ) GO TO 425 IPBUF(23) = 2H- IPBUF(26) = 3 425 CALL INAMR(IPBUF(23),IXBF,120,NCHRS) C C PUSH A NULL FOR # OF LINES PER PAGE C CALL INAMR(IPBUF(111),IXBF,120,NCHRS) C C C************************************************************************** C* NOW LOOK FOR THE LANGUAGE TO SCHEDULE * C************************************************************************** C C IF (IAND(IPBUF(37),3) .NE. 3 ) GO TO 600 C C WE HAVE A LANGUAGE, SEE IF IT MAKES SENSE. C ILANG = 1 IF((IPBUF(34).EQ.2HFT).AND.(IOR(IAND(IPBUF(35),177400B),40B) & .EQ. 2HN )) GO TO 475 C ILANG = 5 IF((IPBUF(34).EQ. 2HMI) .AND. (IPBUF(35) .EQ. 2HCM)) GO TO 475 C C DO 450 ILANG = 1,11 IF(IPROG(1,ILANG) .NE. IPBUF(34)) GO TO 450 IF(IPROG(2,ILANG) .NE. IPBUF(35)) GO TO 450 IF(IPROG(3,ILANG) .NE. IPBUF(36)) GO TO 450 GO TO 475 450 CONTINUE C C IF WE FELL THRU COULDN'T FIND A LANGUAGE C C C C AT THIS POINT WE DON'T HAVE A LANG OR THE LANG SUPPLIED C DIDN'T MAKE ANY SENSE. HOWEVER, WE DO HAVE THE SOURCE C FILE NAME. SO LETS GO OUT AND READ ,SAY, THE FIRST 10 C RECORDS. IF WE FIND A CONTROL STATEMENT THAT MAKES C SENSE WE WILL INVOKE THAT LANGUAGE. C C 600 CALL OPEN(IDCB1,IER,IPBUF,0,IPBUF(5),IPBUF(6)) IF (IER .LT. 0) GO TO 5035 C DO 650 I = 1,10 IPRMT(2) = 2H IPRMT(3) = 2H CALL READF(IDCB1,IER,IPRMT,3,LEN) IF (LEN .EQ. -1) GO TO 660 IF (IER .LT. 0) GO TO 5050 IONE = 1 CALL NAMR(IPBUF(111),IPRMT,5,IONE) C C ILANG = 1 IF((IPBUF(111).EQ.IPROG).AND.(IOR(IAND(IPBUF(112),177400B),40B) & .EQ. 2HN )) GO TO 690 C ILANG = 5 IF((IPBUF(111).EQ. 2HMI) .AND. (IPBUF(112) .EQ. 2HCM)) GO TO 690 C DO 640 ILANG = 1,11 IF ( IPROG(1,ILANG) .NE. IPBUF(111)) GO TO 640 IF ( IPROG(2,ILANG) .NE. IPBUF(112)) GO TO 640 IF ( IPROG(3,ILANG) .NE. IPBUF(113)) GO TO 640 GO TO 690 640 CONTINUE 650 CONTINUE C C OK I GIVE UP ! YOU TELL ME WHICH LANGUAGE YOU WANT. I CAN'T C FIGURE IT OUT. C 660 CALL CLOSE(IDCB1,IER) IF (IER .LT. 0) GO TO 5060 GO TO 5070 C 690 CALL CLOSE(IDCB1,IER) IF (IER .LT. 0 ) GO TO 5060 C C C FOUND A LANGUAGE & IT MAKES SENSE. SO SEE IF THERE ARE ANY C EXTRA PARAMETERS C C C TAKE INTO ACCOUNT CONTROL STATEMENTS THAT DON'T MATCH C PROGRAM NAME. C 475 IF(ILANG .EQ. 8) ILANG = 9 IF(ILANG .EQ. 2) ILANG = 10 C IFLAG = 0 DO 500 I = 45,100,11 ITYPE = IAND(IPBUF(I+3),3) IF(ITYPE .EQ. 3) GO TO 480 IF(ITYPE .EQ. 0) GO TO 500 IF((IPBUF(I) .LT.0) .OR. (IPBUF(I) .GT.9)) GO TO 500 IPBUF(I) = (IPBUF(I) +60B) * 256 + 40B 480 IF (IPBUF(I) .EQ. 20040B) GO TO 500 C C PUSH THE CHARACTER INTO THE BUFFER C CALL CPUT(IPBUF(I)) IFLAG = 1 500 CONTINUE C IF((IFLAG .EQ. 0) .AND. (KOUNT .GT. 3)) CALL CPUT(IOPT) C C C*********************************************************************** C* NOW DO THE ID MANAGEMENT FOR THE LANGUAGE * C*********************************************************************** C C C THE LANGUAGE TO INVOKE IS IPROG(1,ILANG) AND OUR TERMINAL C ASCII LU IS IN ISPOOL(4). SO GET THE NAME NEED FOR IDDUP,IDRPD, C AND IDRPL. C D CALL REIO(2,1,IXBF,-NCHRS) C CALL XQPRG(IDCB1,23,IPROG(1,ILANG),INOP,IXBF,-NCHRS,IRTN,IERROR) IF(IRTN .EQ. 100000B) GO TO 5225 IF(IERROR .NE. 0) GO TO 850 IF(IRTN .NE.0) GO TO 5245 GO TO 899 C 850 GO TO (5080,5240,5090,5155,5105,5140,5080,5225,5225) IERROR C C C************************************************************************* C* SET UP THE LOADR * C************************************************************************* C C FIRST CHECK FOR THE - OPTION. IE &XXXXX GOES TO %XXXXX. C 899 NCHRS = 4 IF(IPBUF(23) .EQ. 0) GO TO 9000 IF(IRELO .EQ. 1) CALL EXEC(3,IPBUF(23)+400B) IF (IPBUF(23) .NE. 2H- ) GO TO 900 IPBUF = IAND(IPBUF,377B) + 22400B CALL INAMR(IPBUF,ILOADR,34,NCHRS) GO TO 925 C 900 CALL INAMR(IPBUF(23),ILOADR,34,NCHRS) C 925 ILOAD(2) = ILOAD(2) + ISPOOL(4)/256 ILOAD(3) = INAME(3) CALL INAMR(IPBUF(12),ILOADR,34,NCHRS) C CALL XQPRG(IDCB1,23,ILOAD4,INOP,ILOADR,-NCHRS,IRTN,IERROR) C C OK, SO NOW CHECK FOR ERRORS. C IF(IRTN .EQ. 100000B) GO TO 6230 IF(IERROR .NE. 0) GO TO 950 IF(IOR(IAND(IRTN(4),177400B),40B) .EQ.2HL ) GO TO 6250 GO TO 9000 C 950 GO TO (5079,5240,6090,6155,6105,6140,5079,6230,6230)IERROR C C OK SO YOU MADE IT. NOW LETS CLEAN UP THE MESS WE MADE. C FIRST GET LETS RETURN THE SPOOL LU. THEN WE'LL GET RID OF THE C ID SEGMENT. C C C C C C*************************************************************************** C* ERRORS * C*************************************************************************** C C 5005 CALL CLERR(1,0,LU) 5010 CALL EXEC(2,LU,IM5010,18) GO TO 9000 C 5020 IFMERR(8) = IKVT( - IER) CALL EXEC(2,LU,IFMERR,23) CALL EXEC(2,LU,IPROCD,21) GO TO 399 C 5035 CALL CLERR(2,0,LU) 5040 IFMGR(8) = IKVT( - IER) IFMGR(7) = 2H-0 CALL EXEC(2,LU,IFMGR,12) CALL EXEC(2,LU,IM5040,16) CALL CLOSE(IDCB1,IER) GO TO 9000 C 5050 CALL CLERR(3,0,LU) IM5040(11) = 2HRE IM5040(12) = 2HAD GO TO 5040 5060 CALL CLERR(4,0,LU) IM5040(11) = 2HCL IM5040(12) = 2HOS IM5040(13) = 2HE GO TO 5040 C 5070 CALL CLERR(5,0,LU) CALL EXEC(2,LU,IM5070,15) GO TO 9000 C 5079 IM5080(5) = 2H IM5080(6) = 2HLO IM5080(7) = 2HAD IM5080(8) = 2HR CALL CLERR(36,0,LU) GO TO 5085 5080 CALL CLERR(6,0,LU) 5085 CALL EXEC(2,LU,IM5080,17) GO TO 9000 C 5090 CALL CLERR(7,0,LU) IM5090(5) = IPROG(1,ILANG) IM5090(6) = IPROG(2,ILANG) IM5090(7) = IPROG(3,ILANG) 5095 CALL EXEC(2,LU,IM5090,20) GO TO 9000 C 5105 CALL CLERR( 8,0,LU) IER = IRTN 5110 IFMGR(8) = IKVT(IABS(IER)) IFMGR(7) = 2H 0 IF(IER .LT.0) IFMGR(7) = 2H-0 CALL EXEC(2,LU,IFMGR,12) CALL EXEC(2,LU,IM5110,20) GO TO 9000 C 5130 CALL CLERR(11,0,LU) CALL EXEC(2,LU,IM5130,16) GO TO 9000 C 5140 IM5110(5) = 2HCK IM5110(6) = 2HSU IM5110(7) = 2HM IER = 19 CALL CLERR(9,0,LU) GO TO 5110 5155 IM5110(5) = 2HOP IM5110(6) = 2HEN IM5110(7) = 2H CALL CLERR(10,0,LU) IER = IRTN GO TO 5110 5225 CALL CLERR(12,0,LU) 5230 CALL EXEC(2,LU,IM5230,18) GO TO 9000 C 5240 IFMGR(7) = 2H 0 IFMGR(8) = 2H14 CALL CLERR(14,0,LU) CALL EXEC(2,LU,IFMGR,12) CALL EXEC(2,LU,IM5240,17) GO TO 9000 C 5245 CALL CLERR(13,0,LU) 5250 CALL EXEC(2,LU,IM5250,18) IRTN = 100000B GO TO 9000 C 5260 CALL CLERR(15,0,LU) CALL EXEC(2,LU,IM5260,10) GO TO 9000 6090 IM5090(5) = 2HLO IM5090(6) = 2HAD IM5090(7) = 2HR CALL CLERR(33,0,LU) GO TO 5095 C 6105 CALL CLERR(30,0,LU) IER = IRTN 6110 IM5110(16) = 2H L IM5110(17) = 2HOA IM5110(18) = 2HDR IM5110(19) = 2H IM5110(20) = 2H GO TO 5110 C 6140 IM5110(5) = 2HCK IM5110(6) = 2HSU IM5110(7) = 2HM IER = 19 CALL CLERR(31,0,LU) GO TO 6110 6155 IM5110(5) = 2HOP IM5110(6) = 2HEN IM5110(7) = 2H CALL CLERR(32,0,LU) IER = IRTN GO TO 6110 C 6230 IM5230(5) = 2H IM5230(6) = 2HLO IM5230(7) = 2HAD IM5230(8) = 2HR CALL CLERR(34,0,LU) GO TO 5230 C 6250 IM5250(5) = 2H IM5250(6) = 2HLO IM5250(7) = 2HAD IM5250(8) = 2HR CALL CLERR(35,0,LU) GO TO 5250 6260 CALL CLERR(37,0,LU) CALL EXEC(2,LU,IM6260,19) C 9000 IF(ISLU .GT. 0) CALL EXEC(23,ISMP,4,ISLU) 9999 CALL EXEC(2,LU,IDONE,6) CALL PRTN(IRTN) CALL EXEC(6,0) END END$