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,2H.S,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$
                                                                                                                                                                                          