FTN4
      SUBROUTINE TMGCR(IERFL),92903-16401 REV.1913  781115
C 
C 
C     NAME:   TMGCR,HDR,EXTNL,DBL,MONAM,FLHND,MRLOC,NBTUS,STUSP 
C     SOURCE: &TMGCR    92903-18401 
C     RELOC:  %TMGCR    92903-16401    PART OF  RTMGLB
C 
C     PGMR:   FRANCOIS GAULLIER   HPG 
C 
C 
C     **************************************************************
C     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  ALL RIGHTS    *
C     * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
C     * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
C     * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
C     **************************************************************
C 
C 
C     *************************************** 
C     * THIS ROUTINE CREATES ALL RELOCATA-  * 
C     * TABLE AND TRANSFER FILES ASSOCIAT-  * 
C     * TED TO AN APPLICATION.              * 
C     * THIS ROUTINE IS COMMON TO TMPGN AND * 
C     * TMSGN PROGRAMS.                     * 
C     *************************************** 
C 
C 
C     STOP USED: 3050 - 3052
C     ----------
C 
C     IERFL   ERROR FLAG RETURN BY THE COMPILER:
C       =0    RETURN OK, LOAD ALL PROGRAMS. 
C       =3    FATAL ERROR, WAIT ACKNOWLEDGMENT FROM OPERATOR
C                          AND TERMINATE. 
C       =-1   FATAL ERROR, NO ROOM ON CARTRIDGE, WRITE MESSAGE AND
C                          AND TERMINATE. 
C 
C 
C     IERFLG  ERROR FLAG
C     IERTN   RETURN ADDR IN CASE OF  CR FULL 
C     ITMFL   TMSLB EXISTENCE FLAG
C 
C 
C     IRQFLG(1)  : MAIN PROGRAM 
C                      BIT15  LOADER MUST USE COMMAND FILE
C                      BIT14  SYSTEM COMMON IS USED (MAIN MUST ACCESS IT) 
C     IRQFLG(2)  : TMST-TMSL-TMSIM
C     IRQFLG(3)  : USER PARTITION # 1 
C     IRQFLG(I)  : USER PARTITION # (I-2) 
C 
C 
C 
C-----LABEL COMMON # 1  GENERAL INFORMATION 
C 
      COMMON /TMGC1/LU
C 
C-----LABEL COMMON # 2  FLAGS 
C 
      COMMON /TMGC2/ITMFL,IRQFLG(30)
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IDUM0(7),NCRTH(1) 
C 
C-----LABEL COMMON # 4  BUFFER USED IN CREATION PHASE & ERROR FLAG
C 
      COMMON /TMGC4/IERFLG,IERNB,IERTN,ITEMP(40)
C 
C 
      DIMENSION IASMB(6),IMESA(23),IEROR(10)
C 
      LOGICAL STUSP,DORMT,ISBIT 
C 
      DATA IMESA/15530B,15555B,15446B,2Hk0,2HB ,15510B,15512B,15542B
     .,2H  ,15446B,2HdC,2HCR,2HEA,2HTI,2HON,2H P,2HHA,2HSE,15446B 
     .,2Hd@,6412B,5012B,15554B/ 
      DATA IEROR/6412B,6412B,15446B,2HdC,2HER,2HRO,51033B,2H&d
     .,2H@ ,2H: / 
C 
C-----INIT INTERNAL COMPILER ERROR FLAG [IERFLG]
C     INIT ERROR ADDRESS RETURN INTO  IERTN 
C 
      IERFLG=0
      ASSIGN 5200 TO IERTN
      IERNB=0 
      CALL EXEC(2,LU,IMESA,23)
C 
C------STOP THE TMS APPLICATION ! 
C 
      CALL MOVEW(NCRTH(5),ITEMP,2)
      ITEMP(3)=2H 
      CALL LURQ(100000B,0,0)
      CALL ETMSP(ITEMP,99)
      CALL LURQ(1,LU,1) 
C 
C     CHECK EXISTANCE OF  %TMSLB (INIT FLAG  ITMFL )
C 
      CALL FLHND(0,2HCK)
C 
      IF(IRQFLG.EQ.0) GOTO 1000 
C 
C   ****************************************************************
C   *                                                              *
C   *                                                              *
C   *          TMS-MAIN PROGRAM GENERATION                         *
C   *                                                              *
C   *                GENERATES FILES: %XXXX - >XXXX                *
C   *                                                              *
C   *                                                              *
C   ****************************************************************
C 
      IRQFLG=1
      CALL FLHND(2H  ,2HOP) 
C 
C     MAIN PROGRAM GENERATION  (%XXXX)
C 
      LTUSEN=5
      LUPTEN=5
      NTUS=NBTUS(NCRTH) 
      NUPT=NBUPT(NCRTH) 
      IPARA=16B 
      LTMSAD=IPARA+3
      ID0ADR=LTMSAD+7+NCRTH(26)*12
      ITMLU=ID0ADR+4
      ITMSB=ITMLU+1+NCRTH(4)-NCRTH(2) 
      ITMPR=ITMSB+1+LTUSEN*NTUS 
      LENPRG=ITMPR+1+LUPTEN*NUPT
C 
      CALL HDR(2H  ,LENPRG) 
C 
      CALL EXTNL(2H  )
C 
      CALL DBL(0,2HIN)
      CALL DBL(76000B+IPARA,2HMR) 
      CALL DBL(16001B,2HX ) 
      CALL DBL(IPARA,2HR )
      CALL DBL(IPARA,2HR )
      IF(STUSP(NCRTH(18),L,K))  STOP 3050 
      L=ITMSB+1+(L-1)*LTUSEN
      CALL DBL(L,2HR )
      IF(STUSP(NCRTH(22),L,K))  GOTO 30 
      L=ITMSB+1+(L-1)*LTUSEN
      GO TO 40
30    L=ID0ADR
40    CALL DBL(L,2HR )
C        SET UP THE   'DEF LUINP' 
      CALL DBL(IPARA+1,2HR )
C        SET UP THE   'DEF .TMLU' 
      CALL DBL(ITMLU,2HR )
C        SET UP THE   'DEF .TMTP' 
      CALL DBL(((NCRTH(4)-NCRTH(2))/2)+ITMLU,2HR )
C        SET UP THE   'DEF .TMSB' 
      CALL DBL(ITMSB,2HR )
C        SET UP THE   'DEF .TMPR' 
      CALL DBL(ITMPR,2HR )
C        SET UP: 'DEF TMSL' , 'DEF TMST' AND 'DEF IMAGE'
      CALL DBL(LTMSAD,2HR ) 
      CALL DBL(LTMSAD+3,2HR ) 
      CALL DBL(LTMSAD+6,2HR ) 
      CALL DBL(0,2H  )
C        SET UP INITIAL PROCESS LU & LOGGING LU 
      CALL DBL(NCRTH(25),2H  )
      CALL DBL(NCRTH(13),2H  )
C        SET UP 'TMSL' AND 'TMST' PROGRAM NAME
      IASMB(3)=2H 
      CALL MOVCA(NCRTH,9,IASMB,2,4) 
      CALL PUTCA(IASMB,1HL,1) 
      CALL MONAM(IASMB) 
      CALL PUTCA(IASMB,1HT,1) 
      CALL MONAM(IASMB) 
C        SET UP IMAGE THINGS
      CALL DBL(NCRTH(26),2H  )
      IF(NCRTH(26) .EQ. 0)  GOTO 60 
      J=27
      DO 55 I=1,NCRTH(26) 
      DO 53 K=1,4 
      CALL MONAM(NCRTH(J))
53    J=J+3 
55    J=J+3 
C        SET UP CONSTANT 0
60    CALL DBL(0,2H  )
C 
C     GENERAL INFORMATION: EMA SIZE - # OF LU - # OF INT. LU - STACK SZ 
C 
      CALL DBL(NCRTH(9),2H  ) 
      CALL DBL((NCRTH(4)-NCRTH(2))/2,2H  )
      CALL DBL((NCRTH(3)-NCRTH(2))/2,2H  )
      CALL DBL(NCRTH(21),2H  )
C        SET UP LOGICAL UNIT/TYPES
      DO 400 J=NCRTH(2),NCRTH(4)-2,2
      CALL DBL(NCRTH(J),2H  ) 
400   CONTINUE
      DO 410 J=NCRTH(2),NCRTH(4)-2,2
      CALL DBL(NCRTH(J+1),2H  ) 
410   CONTINUE
C 
C     TOTAL NUMBER OF TMSUB 
C 
      CALL DBL(NTUS,2H  ) 
C 
C        SET UP TUS TABLE  (LTUSEN WORDS PER ENTRY) 
C 
      N=-1
      J=NCRTH(4)
700   K=NCRTH(J)
      N=N+1 
      DO 710 L=J+3,K-3,3
C-----EXIT THE LOOP WHEN LIBRARY
      IF( ISBIT(NCRTH(L),15) ) GOTO 720 
      CALL MONAM(NCRTH(L))
      CALL DBL(ITMPR+1+N*LUPTEN,2HR ) 
      CALL DBL(0,2H  )
710   CONTINUE
720   J=K 
      IF( J .NE. NCRTH+1 )  GOTO 700
C 
C     NUMBER OF PROGRAMS
C 
      CALL DBL(NUPT,2H  ) 
C 
C     SET UP UPT TABLE  ( LUPTEN WORDS PER ENTRY )
C 
      ICHAR=2HA 
      J=NCRTH(4)
750   CALL MOVEW(NCRTH(5),IASMB,2)
      IASMB(3)=ICHAR
      CALL ISUPB(IASMB,3) 
      CALL MONAM(IASMB) 
C-----SET UP SYSTEM COMMON FLAG (WORD AFTER PNAME)
      L=0 
      IF( ISBIT(NCRTH(J+2),15) )  L=100000B 
      CALL DBL(L,2H  )
      IF(L .NE. 0)  CALL SETBT(IRQFLG,14,1) 
C-----SET BACK POINTER TO 1ST TUS IN THAT UPT 
      IF(STUSP(NCRTH(J+3),L,M))  STOP 3052
      L=ITMSB+1+(L-1)*LTUSEN
      CALL DBL(L,2HR )
      ICHAR=ICHAR+400B
      J=NCRTH(J)
      IF(J .NE. NCRTH+1)  GOTO 750
C 
      CALL DBL(0,2HND)
C 
C     END RECORD
C 
      CALL FLHND(0,2HCS)
C 
      IF(ITMFL .GE. 0)  CALL SETBT(IRQFLG,15,1) 
C 
1000  IF(IRQFLG(2).EQ.0) GOTO 2000
C 
C   ****************************************************************
C   *                                                              *
C   *                                                              *
C   *          TMS-MAIN MODULES GENERATION                         *
C   *                                                              *
C   *                GENERATES FILES: %TXXXX - >TXXXX              *
C   *                                 %LXXXX - >LXXXX              *
C   *                                 %IMAG. - >IMAG.              *
C   *                  AS NEEDED.                                  *
C   *                                                              *
C   *                                                              *
C   ****************************************************************
C 
C 
      IRQFLG(2)=0 
      DO 1500 I=1,2+NCRTH(26) 
C 
      IF(I .GE. 3)  GOTO 1100 
C 
      K=2HT 
      IF(I .EQ. 2)  K=2HL 
      IASMB=K 
      CALL MOVEW(NCRTH(5),IASMB(2),2) 
      CALL ISUPB(IASMB,3) 
      IF(IDGET(IASMB) .NE. 0)  GOTO 1500
      J=1 
      GOTO 1200 
C 
1100  K=I-3 
      L=27+15*K 
      IF(.NOT. DORMT(NCRTH(L+9)) )  GOTO 1500 
      J=6 
C 
1200  CALL FLHND(K,2HOP)
C 
      CALL HDR(K,J) 
C 
      CALL EXTNL(K) 
C 
C     PROGRAM GENERATION
C 
      CALL DBL(0,2HIN)
      IF(I .LT. 3 )  GOTO 1250
C 
      CALL DBL(0,2HC )
      CALL DBL(NCRTH(L+14)-1,2HC )
      CALL DBL(076000B,2HMC)
      CALL DBL(104200B,2H  )
      CALL DBL(0,2HR )
1250  CALL DBL(026001B,2HX )
      CALL DBL(0,2HND)
C 
C     END RECORD
C 
      J=0 
      IF(I .GE. 3) J=2
      CALL FLHND(J,2HCS)
C 
      CALL SETBT(IRQFLG(2),I,1) 
C 
1500  CONTINUE
C-----SET BIT 15 IF LOADER MUST USE COMMAND FILE '>?APLT' 
      IF(IRQFLG(2).NE.0 .AND. ITMFL.GE.0) 
     .                            CALL SETBT(IRQFLG(2),15,1)
C 
C   ****************************************************************
C   *                                                              *
C   *                                                              *
C   *          TMS-USER PARTITION GENERATION                       *
C   *                                                              *
C   *                GENERATES FILES: %XXXXN - >XXXXN              *
C   *                                 AS NEEDED                    *
C   *                                                              *
C   *                                                              *
C   ****************************************************************
C 
2000  DO 2900 I=1,NUPT
      IF(IRQFLG(I+2).EQ.0) GOTO 2900
C 
      CALL FLHND((2H @)+I,2HOP) 
C 
      J=IUPPT(I,N)
C 
      CALL HDR((2H @)+I,4+N)
C 
      CALL EXTNL((2H @)+I)
C 
C     PROGRAM GENERATION  (%XXXXN)
C 
      CALL DBL(0,2HIN)
      CALL DBL(0,2H  )
      CALL DBL(026001B,2HX )
      CALL DBL(N,2H  )
      N=2 
      K=NCRTH(J)
      DO 2030 L=J+3,K-3,3 
C     EXIT THE LOOP WHEN LIBRARY
      IF( ISBIT(NCRTH(L),15) ) GOTO 2040
      CALL DBL(N,2HX )
2030  N=N+1 
C 
C     BIT0  = SWAPPING OPTION (ALWAYS SET NOW !!) 
C     BIT15 = SYSTEM COMMON FLAG
C 
2040  ISWP=1
      IF( ISBIT(NCRTH(J+2),15) )  ISWP=100001B
      CALL DBL(ISWP,2H  ) 
C 
C     WRITE LAST PROGRAM RECORD 
C 
      CALL DBL(0,2HND)
C 
C     END RECORD
C 
      CALL FLHND(0,2HCS)
C 
2900  CONTINUE
C 
C 
C     CREATION PHASE IS COMPLETED, WRITE MESS. ON CRT IF NEEDED 
C     AND RETURN. 
C 
C 
      IERFL=0 
      IF(IERFLG.EQ.0)  RETURN 
      CALL MOVEW(IEROR,ITEMP,10)
      CALL MOVEW(26HLoading impossible due to ,ITEMP(11),13)
      CALL MOVEW(18Hprevious error !  ,ITEMP(24),9) 
      CALL EXEC(2,LU,ITEMP,32)
      IERFL=3 
C-----CLEAR LOADING REQUEST FLAG
5100  DO 5112 I=1,28
5112  IRQFLG(I)=0 
      RETURN
C 
C     NO ROOM ON CARTRIDGE !! 
C 
5200  IERFL=-1
      GOTO 5100 
C 
C-----END OF COMPILER-------------------------
C 
      END 
      SUBROUTINE HDR(IPARM,LEN),92903-16401 REV.1913  790124
C 
C 
C     ******************************************* 
C     *                                         * 
C     * THIS SUBROUTINE GENERATES THE BINARY    * 
C     * NAM RECORD OF ALL PROGRAMS.             * 
C     *                                         * 
C     * CALL HDR(P1,P2)                         * 
C     *                                         * 
C     * P1 - DEFINE THE PROGRAM  (MAIN, USER    * 
C     *      PARTITION, LINK, TIMER OR IMAGE)   * 
C     * P2 - TOTAL LENGTH OF THE MODULE         * 
C     *                                         * 
C     ******************************************* 
C 
C 
      LOGICAL ISBIT 
C 
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IDUM0(7),NCRTH(1) 
C 
C-----LABEL COMMON # 4  BUFFER USED IN CREATION PHASE & ERROR FLAG
C 
      COMMON /TMGC4/IERFLG,IERNB,IERTN,IERMS(7),IRLOC(70),ITRSF(20) 
C 
C 
C     INITIALISATION
C 
      CALL NUL(IRLOC,70)
      IRLOC(2)=20000B 
      CALL MOVEW(NCRTH(5),IRLOC(4),2) 
      IRLOC(6)=IPARM
      IRLOC(7)=LEN
      IRLOC(10)=3 
      IF(IPARM .EQ. 2H  )  GOTO 30
      IF(IPARM .GT. 4   )  GOTO 50
C 
C-----SET UP HEADER FOR TMS IMAGE MODULE
C 
      L=27+15*IPARM 
      CALL MOVEW(NCRTH(L+9),IRLOC(4),3) 
      IRLOC(9)=NCRTH(L+14)
      IRLOC(11)=60
      CALL MOVEW(6HIMAG. ,IRLOC(18),3)
      GOTO 40 
C 
C-----SET UP HEADER FOR TMS LINK & TIMER MODULE 
C 
50    IF(IPARM.NE.2HT  .AND. IPARM.NE.2HL )  GOTO 100 
      IRLOC(4)=IPARM
      CALL MOVEW(NCRTH(5),IRLOC(5),2) 
      IRLOC(11)=10
      CALL MOVEW(6HTIMER ,IRLOC(18),3)
      IF(IPARM .EQ. 2HT )  GOTO 40
      IRLOC(11)=70
      CALL MOVEW(6HLINK  ,IRLOC(18),3)
      GOTO 40 
C 
C-----SET UP HEADER FOR USER PARTITION
C 
100   CALL MOVEW(6HUPT.. ,IRLOC(18),3)
      K=IAND(IPARM,177B)-100B 
      J=IASC(K) 
      CALL MOVCA(J,1,IRLOC,38,2)
      J=IUPPT(K,N)
      IRLOC(11)=65
C-----DETERMINE COMMON SIZE AND CHECK THAT ALL FILES EXIST
      IMAXI=0 
      K=NCRTH(J)
      ISYCOM=32000
      IF(.NOT. ISBIT(NCRTH(J+2),15) )  GOTO 22
      ISYCOM=IGET(1753B)
22    DO 25 I=J+3,K-3,3 
      ITRSF(20)=ISYCOM
      CALL FLHND(I,2HMX)
      IF(IMAXI.LT.ITRSF(9)) IMAXI=ITRSF(9)
25    CONTINUE
      IRLOC(9)=IMAXI
      GOTO 40 
C 
C-----SETUP HEADER FOR MAIN PROGRAM 
C 
30    CALL MOVEW(6HMAIN  ,IRLOC(18),3)
      IRLOC(9)=1
      IRLOC(11)=65
C 
C-----MOVE THE COMMENT AREA 
C 
40    CALL ISUPB(IRLOC(4),3)
      CALL MOVEW(NCRTH(87),IRLOC(21),10)
C 
C-----WRITE HEADER IN THE RELOCATABLE FILE
C 
      CALL FLHND(30,2HWR) 
      RETURN
      END 
      SUBROUTINE EXTNL(IPARM),92903-16401 REV.1913  781113
C 
C 
C 
C     ****************************************
C     *                                      *
C     * THIS SUBROUTINE GENERATES THE EXTER- *
C     * NAL RECORD OF THE MAIN PROGRAM AND   *
C     * PROGRAMS ASSOCIATED TO AN APPLICATION*
C     *                                      *
C     *  CALL EXTNL(P1)                      *
C     *                                      *
C     *  P1 = IDENTIFIES THE MODULE TO BE    *
C     *       GENERATED.                     *
C     *                                      *
C     ****************************************
C 
C 
C 
C 
C-----LABEL COMMON # 2  FLAGS 
C 
      COMMON /TMGC2/ITMFL 
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IDUM0(7),NCRTH(1) 
C 
C-----LABEL COMMON # 4  BUFFER USED IN CREATION PHASE & ERROR FLAG
C 
      COMMON /TMGC4/IERFLG,IERNB,IERTN,IERMS(7),IRLOC(70),ITRSF(20) 
C 
C 
      DIMENSION NAME(3) 
C 
      CALL MOVEW(NCRTH(5),NAME,2) 
      NAME(3)=IPARM 
C 
      IF(IPARM .NE. 2H  )  GOTO 200 
C 
C     GENERATE MAIN PROGRAM EXTERNAL :  '$MTMS' 
C              EMA RECORD 
C 
      CALL MOVEW(6H$MTMS ,IRLOC(4),3) 
      ASSIGN 750 TO IRTRN 
      GOTO 260
C 
200   K=IAND(IPARM,077400B)/256 
      IF(K .EQ. 40B)  GOTO 300
C 
C     GENERATE LINK, TIMER OR IMAGE MODULE EXTERNAL 
C     '$LTMS' OR '$TTMS' OR '$ITMS' 
C 
      CALL MOVEW(6H$ITMS ,IRLOC(4),3) 
      IF(IPARM .LE. 4 )  GOTO 220 
      IRLOC(4)=IOR(22000B,K)
      NAME=IPARM
      CALL MOVEW(NCRTH(5),NAME(2),2)
      GOTO 250
220   CALL MOVEW(NCRTH(27+9+15*IPARM),NAME,3) 
250   ASSIGN 800 TO IRTRN 
260   IRLOC(6)=IAND(IRLOC(6),77400B)+1
      I=7 
      CALL MRLOC(NAME,0,0)
      GOTO 700
C 
C     GENERATE USER PARTITION EXTERNAL : '$TML0' AND
C     ALL THE TUS.
C 
300   CALL MOVEW(6H$TML0 ,IRLOC(4),3) 
      IRLOC(6)=IAND(IRLOC(6),077400B)+1 
C 
C     TRANSFERT FILE GENERATION 
C 
      CALL MRLOC(NAME,0,0)
C     SETUP FOR 'EXT TMSB' GENERATION 
      J=IUPPT(IAND(IPARM,177B)-100B,N)
      L=2 
      I=7 
C 
C     GENERATE BINARY & TRANSFERT FILE AT THE SAME TIME 
C 
      ASSIGN 500 TO IRTRN 
      K=NCRTH(J)
      DO 500 N=J+3,K-3,3
      M=IAND(NCRTH(N),100000B)
      CALL MRLOC(NCRTH(N),M,0)
      IF(M .NE. 0)  GOTO 500
      CALL MOVEW(NCRTH(N),IRLOC(I),3) 
      IRLOC(I+2)=IAND(IRLOC(I+2),077400B)+L 
      L=L+1 
      I=I+3 
      IF(I.GE.59)  GOTO 700 
500   CONTINUE
      ASSIGN 800 TO IRTRN 
C 
C     OUTPUT EXTERNAL RECORD
C 
700   IRLOC(2)=100000B+(I-4)/3
      CALL FLHND(I-1,2HWR)
      I=4 
      GOTO IRTRN
C 
C     OUTPUT EMA RECORD (MAIN PROGRAM ONLY) 
C 
750   IRLOC(2)=140000B+NCRTH(9) 
                                                                                                                                                                                                                                                        