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$
                                                                                                                                        