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$