FTN4,L
C 
C 
C 
C     NAME:   STRTM 
C     SOURCE: 92064-18098   REV 1709    770310
C     RELOC:  92064-16080 
C     PGMR:   R.K.J.
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977.  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 
      PROGRAM STRTM,1,1 
C 
      DIMENSION IBUF(105),IBUF2(33),NAPLD(3),NFIL(4)
     1,         IDCB(144),NAM(3),NERR(6),MERR(10),NMOFF(5)
C 
      EQUIVALENCE (NAM,IBUF2(2)),(NERR2,NERR(2))
     1,(K1,IBUF2(1)),(IC1,IBUF2(2)),(IC2,IBUF2(3)),(IC3,IBUF2(4)) 
     2,(K2,IBUF2(5)),(IP1,IBUF2(6)),(K3,IBUF2(9)),(IP2,IBUF2(10)) 
     3,(K4,IBUF2(13)),(IP3,IBUF2(14)),(K5,IBUF2(17)),(IP4,IBUF2(18))
     4,(K6,IBUF2(21)),(IP5,IBUF2(22)),(MERR,NFIL),(MERR(5),NERR)
C 
      DATA NAPLD/2HAP,2HLD,2HR /, NFIL/2H&S,2HTR,2HCM,2H  / 
     1,    ISCD/-2/, NERR/2HFM,2HP ,2HER,2HR ,2*2H  /,MXCD/+1/
     2,    NMOFF/2HOF,2H,S,2HTR,2HTM,2H,8/,IBUF/100*0/
C 
C     CHECK FOR REEXECUTION TRY, AND REJECT IT
C 
      IF(MXCD.NE.1) GOTO 990
      MXCD=-1 
C 
C     OPEN "&STRCM" FILE
C 
      CALL OPEN(IDCB,IERR,NFIL,0,ISCD)
      IF(IERR.LT.0) GOTO 800
C 
C     SCHEDULE "APLDR" TO LOAD PROGRAMS SPECIFIED IN THE "&STRCM" FILE
C 
  100 CALL READF(IDCB,IERR,IBUF,20,LEN) 
      IF(IERR.NE.0) GOTO 800
      IF(IBUF.EQ.2H/E) GOTO 200 
C 
      CALL PARSE(IBUF,LEN*2,IBUF2)
      IF(K1.NE.2) GOTO 870
C 
  110 LP1=1 
      LP2=0 
      IF((K2.EQ.1).AND.(IP1.EQ.2)) LP1=2
      IF(K3.EQ.1) LP2=IP2 
      IF(K4.EQ.1) LP2=512*IP3 + IP2 
C 
  120 CALL EXEC(9,NAPLD,LP1,LP2,IC1,IC2,IC3)
      IF(IFBRK(I)) 900,100
C 
C     EXECUTE PROGRAMS SPECIFIED IN THE "&STRCM" FILE 
C 
  200 DO 290 I=1,86,21
      CALL READF(IDCB,IERR,IBUF(I),20,IBUF(I+20)) 
      IF(IERR.NE.0) GOTO 800
      IF(IBUF(I).EQ.2H/E) GOTO 299
  290 CONTINUE
  299 CALL CLOSE(IDCB,IERR) 
C 
  300 DO 399 I=1,86,21
      IF(IBUF(I).EQ.2H/E) GOTO 990
      CALL PARSE(IBUF(I),2*IBUF(I+20),IBUF2)
C 
      IF(K1.NE.2) GOTO 870
      CALL EXEC(10,NAM,IP1,IP2,IP3,IP4,IP5) 
      IF(IFBRK(I)) 900,399
  399 CONTINUE
      GOTO 990
C 
C     ERROR PROCESSING SECTION
C 
  800 IF(IERR.GE.0) GOTO 805
      IERR=-IERR
      NERR(5)=2H -
  805 NERR(6)=KCVT(IERR)
      IWD=10
  810 CALL EXEC(2,1,MERR,IWD) 
      GOTO 900
C 
  870 NERR=2HIN 
      NERR2=2HP 
      IWD=8 
      GOTO 810
C 
  900 CALL CLOSE(IDCB,IERR) 
  990 I=MESSS(NMOFF,10) 
      END 
      END$
                                                                    