FTN4,L C <800822.0734> 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: PGRUN C SOURCE: 92074-18006 C RELOC: PART OF 92074-1X006 C PGMR: J.D.J. C C INTEGER FUNCTION PGRUN(STR,LEN,IPOS) C,92074-1X006 REV.2034 800818 CC C EDIT/1000 RUN A PROGRAM SUBROUTINE C C IPOS POINTS TO PROGRAM NAME C C WE WILL BUILD A RU,PROG,STING LINE TO PASS TO XQPRG C C SUBSTITUTE COMMAS TO SEPARATE PARAMTERERS C INTEGER STR(LEN),LEN,IPOS,C,I,J,LBYTE,ENDQ INTEGER BUFFER(77),IDCB(144),IPROG(10),IPRAM(5),TBUFF(10) INTEGER IRTN(5) C C C DATA BUFFER(1)/2HRU/ DATA BUFFER(2)/2H, / C C KILL LEADING BLANKS C I = IPOS J = 4 CALL STRPB(STR,I,LEN) C C WORK ON STRING, DISPACTHING ON EACH CHARACTER C 30 IF( I .GT. LEN ) GOTO 9999 C = LBYTE(STR,I) C C C IS IT A BLANK ? C IF( C .NE. 40B ) GOTO 40 C IT'S A BLANK - SKIP UNTIL WE FIND A NON-BLANK OR END FO STRING CALL STRPB(STR,I,LEN) C PUT IN A COMMA IF NOT AT EOS IF( I .GT. LEN) GOTO 9999 CALL SBYTE(BUFFER,J,54B) J = J + 1 C CHECK TO SEE IF WE HIT A COMMA C = LBYTE(STR,I) IF( C .NE. 54B ) GOTO 30 C FOUND A COMMA -- SKIP IT AND STRIP BLANKS I = I + 1 CALL STRPB(STR,I,LEN) GOTO 30 C C IS IT A COMMA ? C 40 IF( C .NE. 54B ) GOTO 50 C IT'S A COMMA - APPEND IT AND KILL BLANKS CALL SBYTE(BUFFER,J,54B) J = J + 1 I = I + 1 CALL STRPB(STR,I,LEN) GOTO 30 C C IS IT A QUOTE CHAR ? C 50 IF( C .NE. 140B ) GOTO 60 C IT'S A QUOTE (REALLY AN `) ENDQ = C 55 I = I + 1 IF( I .GT. LEN ) GOTO 9999 C = LBYTE(STR,I) IF( C .EQ. ENDQ ) GOTO 57 53 CALL SBYTE(BUFFER,J,C) J = J + 1 GOTO 55 C C TEST FOR TWO QUOTES AND USE AS SINGLE ONE 57 I = I + 1 IF( I .GT. LEN ) GOTO 9999 C = LBYTE(STR,I) IF( C .EQ. ENDQ ) GOTO 53 GOTO 30 C C ELSE IT'S SOME OTHER CHARACTER - JUST MOVE (FOLD) IT C C FOLD CASE IF NEEDED 60 IF( (C .GE. 141B) .AND. (C .LE. 172B) ) C = C - 40B CALL SBYTE(BUFFER,J,C) J = J + 1 C C C 100 I = I + 1 GOTO 30 C C 9999 LENGTH = J-1 C C PUT IN A BLANK IN CASE OF ODD LENGTH STRING C CALL SBYTE(BUFFER,J,40B) C C NOW WE HAVE THE STRING TO PASS - PARSE OUT THE NAME, ECT. C J = 1 DO 700 I = 1,2 IF( NAMR(IPROG,BUFFER,LENGTH,J) ) 111,700 700 CONTINUE C C GET NUMBERIC PARAMS C DO 710 I = 1,5 JUNK = NAMR(TBUFF,BUFFER,LENGTH,J) IPRAM(I) = TBUFF(1) 710 CONTINUE C C IF FIRST IS ZERO PUT IN LU INSTEAD C IF( IPRAM(1) .EQ. 0 ) IPRAM(1) = LOGLU(JUNK) C C TEST FOR NO CLONING C IH = 0 IF(IPROG(5) .EQ. 2HIH ) IH = -1 C C GO CLONE AND RUN THE GUY C CALL XQPRG(IDCB,23,IH,IPROG,IPRAM,BUFFER,-LENGTH,IRTN,IER) PGRUN = IER C C CHANGE ERROR CODE TO APPROXIMATE FMGR CODE C IF(IER .EQ. 1) PGRUN = 23 IF(IER .EQ. 2) PGRUN = 9 IF(IER .EQ. 3) PGRUN = 67 IF(IER .EQ. 4) PGRUN = IRTN(1) IF(IER .EQ. 5) PGRUN = IRTN(1) IF(IER .EQ. 6) PGRUN = 19 IF(IER .EQ. 7) PGRUN = 17 IF(IER .EQ. 8) PGRUN = 0 IF(IER .EQ. 9) PGRUN = 67 C C PUT ERROR IN THE SCB C IF(IER .NE. 0 ) CALL PTFME(IER) RETURN C C HERE WHEN THERE WAS NO PROG NAME C 111 IERR = 0 RETURN END C C SUBROUTINE STRPB(STR,I,LEN) C,92074-1X006 REV.2034 800818 C C STRIP BLANKS - INCR I C INTEGER STR(LEN),I,LEN,C 10 C = LBYTE(STR,I) IF( C .NE. 40B ) RETURN I = I + 1 IF ( I .GT. LEN ) RETURN GOTO 10 C END 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: XXXXX-XXXXX C RELOC: XXXXX-XXXXXX C PGMR: C.M.M., J.D.J. 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 ABLUA PROGRAM. CONTINUE INCREMENTING C THE LAST CHAR. UNTIL SOME OTHER ERROR HAPPENS. C A. IF SUCCESS SCHEDULE ABLUA 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,IH,IPROG,IG,IBX,IL,IRTN,IER) C,92074-1X006 REV.2034 800818 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 IH - 0=> CLONE; NOT 0 => DON'T COLNE 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 = 1 I100 = 2HA LU = LOGLU(LU) CALL LUTRU(LU,LUX) LUX = IKVT(LUX) DO 5 I = 1,3 5 INAME(I) = IPROG(I) C C CHECK INHIBIT CLONING FLAG C IF( IH .NE. 0 ) GOTO 1000 C 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 C C BUILD ABCLU NAME C NOID = 0 INAME(2) = IAND(IPROG(2),77400B) + LUX/256 INAME(3) = IAND(LUX,377B) * 256 + 40B C C REPLACE BLANKS BY DOTS C DO 10 I = 2,5 10 IF( LBYTE(INAME,I).EQ.40B ) CALL SBYTE(INAME,I,56B) C C C SPECIAL CASE FMGR TO FMLUA C IF( (IPROG(1).EQ.2HFM) .AND. (IPROG(2).EQ.2HGR) .AND. & (IPROG(3).EQ.2H ) ) GOTO 100 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 1 2 3 4 5 6 7 8 9 10 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 INAME(2) = LUX INAME(3) = I100 I100 = I100 + 400B 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$