FTN4,L
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:   XQPRG 
C           SOURCE: 92067-18463 
C           RELOC:  92067-16125 
C           PGMR:   C.M.M.
C 
C 
C  THE XQPRG ROUTINE IS A MEANS TO SCHEDULE A PROGRAM TO BE RUN.
C  IT MAKES EVERY ATTEMPT TO EITHER 'RP' OR SCHEDULE THE REQUESTED
C  PROGRAM. IT WILL RENAME THE PROGRAM IF POSSIBLE. 
C 
C 
C   SEQUENCE OF EVENTS :
C 
C       I.  DUP OR RP A COPY OF PROG ABCDE TO ABCLU 
C           A. IF SUCCESS SCHEDULE THE PROGRAM
C           B. FAILURE
C               1.  IF ALREADY CLONED BUT NOT DORMANT OR IF ANOTHER 
C                   PROGRAM (ABCPQ) ALREADY HAS THE NAME ABCLU TRY TO 
C                   CLONE AN  AB.LU  PROGRAM. 
C                     A.  IF SUCCESS SCHEDULE  AB.LU
C                     B.  FAILURE 
C                         1.  IF ORGINAL PROGRAM RP'D SCHEDULE ORGINAL. 
C                         2.  IF ORGINAL PROGRAM NOT RP'D THEN RP IT
C                               A. IF SUCCESS SCHEDULE ORGINAL
C                               B. IF FAILURE RETURN IER = 1
C               2.  IF NO ID SEGMENTS SCHEDULE THE ORGINAL
C                   IF ORGINAL NOT RP'D RETURN IER = 2
C               3.  IF CLONING ILLEGAL IE THE DON'T COPY BIT IS 
C                   SET, THEN SCHEDULE THE ORGINAL. 
C 
C 
C 
C 
C 
C 
C 
      SUBROUTINE XQPRG(IDCB,ICD,IPROG,IG,IBX,IL,IRTN,IER) 
     C,92067-16125 REV.1903 781025
C 
C           IDCB   -      144 WORD DATA CONTROL BLOCK 
C           ICD    -      NO ABORT SCHEDULE REQUEST CODE. EXEC 9,10,23,24 
C                         DON'T SET THE NO ABORT BIT.  I'LL DO IT.
C           IPROG  -      5 CHARACTER ASCII PROGRAM NAME
C           IBX    -      80 CHARACTER STRING WHICH IS PASSED TO SCHEDULED PRG
C           IL     -      LENGTH OF ACTUAL INFO BEING PASSED(+WDS,-CHARS) 
C           IG     -      5 WORD ARRAY TO BE PASSED TO SCHEDULED PROGRAM
C           IRTN   -      5 WORD ARRAY PASSED BACK FROM SCHEDULED PROGRAM 
C           IER    -      1 WORD ERROR FLAG, AS FOLLOWS:
C 
C 
C 
C    ON RETURN :   IER  = 0     SUCCESS 
C 
C                  IER  = 1     THE DUPLICATION HAS FAILED.  I TRIED TO 
C                               SCHEDULE AN ABCLU AN AB.LU AND EVEN THE 
C                               THE ORGINAL ABCDE.  EITHOR ALL OF THESE 
C                               NAMES WERE TAKEN BY A DIFFERENT PROGRAM 
C                               OR ABCLU  AND/OR AB.LU WERE ALREADY CLONED
C                               AND BUSY AND THE ORGINAL ABCDE CAN'T BE 
C                               RP'D.  IF YOU GET THIS ERROR JUST ISSUE 
C                               A ' DUPLICATE PROGRAM ERROR ' MESSAGE 
C                               AND FORGET IT.
C 
C                 IER  = 2      SYSTEM OUT OF ID SEGMENTS.  I EVEN TRIED
C                               TO SCHEDULE THE ORGINAL PROGRAM BUT IT
C                               WAS BUSY OR NOT RP'D INTO THE SYSTEM. 
C 
C                 IER  = 3      PROGRAM NOT FOUND.  IE I COULDN'T FIND IT 
C                               ANYWHERE ON LU 2 OR LU 3 OR ANYPLACE. 
C 
C                 IER  = 4      OPEN ERROR.  I WENT OUT TO LU2 OR LU3 
C                               TO FIND THE PROGRAM & DID INDEED FIND IT. 
C                               HOWEVER, WHEN I WENT TO OPEN THAT FILE TO 
C                               CREATE THE ID SEGMENT AN FMP ERROR OCCURED. 
C                               THE ERROR WILL BE IN THE IRTN(1) PARAMETER. 
C 
C                 IER  = 5      CLOSE ERROR.  FOUND THE PROGRAM ON THE DISC 
C                               BUT WHEN I CLOSED THE FILE AN FMP ERROR 
C                               OCCURED.  THE ERROR WILL BE IN IRTN(1). 
C 
C                 IER  = 6      CHECKSUM ERROR.  THE PROGRAM WAS FOUND ON 
C                               THE DISC BUT WITH A CHECKSUM ERROR.  THE
C                               PROGRAM WAS PROBABLY NOT LOADED ON THIS 
C                               SYSTEM. 
C 
C                 IER  = 7      THIS PROGRAM CAN'T BE COPIED. SO I TRIED
C                               TO SCHEDULE THE ORGINAL BUT IT EITHOR 
C                               COULDN'T BE FOUND OR WAS BUSY.
C 
C                 IER  = 8      THE PROGRAM ABORTED ABNORMALLY OR PASSED
C                               BACK A 100000B AS THE 1ST RETURN PARAMETER
C                               VIA THE SUBROUTINE PRTN.
C 
C                 IER  = 9      THE EXEC CALL FAILED.  THIS SHOULD NEVER
C                               HAPPEN. 
C 
      DIMENSION IDCB(144),IBX(40),IRTN(5),INAME(3),IPROG(3),IG(5) 
C 
C 
      IKVT(IERP) = 2H00 + (IERP/10*256) + MOD(IERP,10)
C 
C 
C        SET A FEW FLAGS
C 
      NOID = 0
      I100 = 0
      LU = LOGLU(LU)
      CALL LUTRU(LU,LUX)
      LUX = IKVT(LUX) 
C 
C           THE LANGUAGE TO INVOKE IS IPROG(1) AND OUR TERMINAL 
C           ASCII LU IS IN LUX. SO GET THE NAME NEED FOR THE CLONE. 
C 
C 
      INAME(1) = IPROG(1) 
      INAME(2) = IAND(IPROG(2),77400B) + LUX/256
      INAME(3) = IAND(LUX,377B) * 256 + 40B 
C 
C 
C                 ************************************
C                 *        CLONE AN ID SEG           *
C                 ************************************
C 
1     CALL CLONE(IDCB,IPROG,INAME,IPRGID,INAMID,IERRR,IFMPER) 
      IRTN(1) = IFMPER
C 
C 
C     IERRR = 1      SUCCESS
C     IERRR = 2      ALREADY CLONED BUT NOT DORMANT 
C     IERRR = 3      DUPLICATE PROG NAME (NOT THE SAME PROG)
C     IERRR = 4      SYSTEM OUT IF ID SEGS
C     IERRR = 5      NO SUCH PROGRAM
C     IERRR = 6      FMP OPEN ERROR 
C     IERRR = 7      FMP CLOSE ERROR
C     IERRR = 8      CHECKSUM ERROR. PROG NOT LOADED ON THIS SYS
C     IERRR = 9      THIS PROG CAN'T BE COPIED
C     IERRR = 10     ILLEGAL PROGRAM NAME 
C 
C 
      GO TO (1000,100,100,150,5030,5040,5050,5060,250,200)IERRR 
C 
C     AT THIS POINT WE KNOW THAT THE ORGINAL CLONE REQUEST
C     DIDN'T WORK.  EITHOR THE NAME IS BEING USED BY A DIFFERENT
C     PROGRAM OR THE SAME PROGRAM HAS ALREADY BEEN CLONED AND 
C     BUT THAT PROGRAM IS BUSY.  SO TRY A XX.LU NAME.  IF THAT DOESN'T
C     WORK TRY TO USE THE ORGINAL.  IF THAT DOESN'T WORK JUST FORGET IT.
C 
C 
100   IF(I100 .EQ. 1) GO TO 200 
      I100 = 1
      INAME(2) = IOR(IAND(INAME(2),377B),27000B)
      GO TO 1 
C 
C     NO ID SEGS SEE OF ORGINAL IN MEMORY 
C 
150   IF(IPRGID .EQ. 0) GO TO 5020
      GO TO 250 
C 
C 
C     NAME I CAME UP WITH DIDN'T WORK.  SO TRY THE
C     ORGINAL.
C 
200   IF(IPRGID .NE. 0) GO TO 250 
C 
C           ORGINAL NOT RP'D SO RP IT.
C 
      CALL CLONE(IDCB,IPROG,IPROG,IPRGID,IPRGID,IERRR,IFMPER) 
      GO TO (250,250,5010,5020,5030,5040,5050,5060,250,5010) IERRR
C 
C 
250   INAME(1) = IPROG(1) 
      INAME(2) = IPROG(2) 
      INAME(3) = IPROG(3) 
      NOID = 1
C 
C************************************************************************** 
C           OK WE DID IT LETS INVOKE THE LANGUAGE 
C 
1000  CALL  EXEC(ICD+100000B,INAME,IG(1),IG(2),IG(3),IG(4),IG(5)
     1 ,IBX,IL) 
C 
C*************************************************************************
C 
      GO TO 5000
1001  CALL ABREG(IA,IB) 
      IF(IB .NE. 0) CALL RMPAR(IRTN)
      IF (NOID.EQ.0) CALL IDRPD(INAME,IERX) 
      IF(IRTN .EQ. 100000B) GO TO 5080
C 
C           SUCCESS !!!!!!!!!!! 
C 
      IER = 0 
      RETURN
C 
C 
C 
C                 ************************************* 
C                 *              ERRORS               * 
C                 ************************************* 
C 
C 
5000  IF(NOID .EQ.0) CALL IDRPD(INAME,IERX) 
      IER = 9 
      RETURN
5010  IER = 1 
      RETURN
5020  IER = 2 
      RETURN
5030  IER = 3 
      RETURN
5040  IER = 4 
      RETURN
5050  IER = 5 
      RETURN
5060  IER = 6 
      RETURN
5070  IER = 7 
      RETURN
5080  IER = 8 
      RETURN
      END 
      END$
                                                                          