FTN4
C 
C 
C     NAME:   DEPAK,REPAK,CLSLU,ISPRZ,ITRIC,NBUPT 
C     SOURCE: &TMGL0    92903-18405 
C     BINARY: %TMGL0    92903-16405    PART OF  RTMGL1
C 
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     PGMR:   DANIEL POT   HPG
C 
C 
      SUBROUTINE DEPAK,92903-16405 REV.1913  781109 
C 
C 
C     **************************************************
C     * IT DEPACKS IT BY EXTENDING INTERACTIVE AND AU- *
C     * XILIARY LU UP TO 64 AND GENERATING PARTITIONS  *
C     * INCLUDING 20 TMS-SUBROUTINES AND 3 LIBRARIES   *
C     * EACH OF THEM. ( EXTENSIONS WILL BE GENERATED). *
C     **************************************************
C 
C     STOP USED:  7010 - 7012 - 7013
C     ----------
C 
C 
C          FORMAT OF THE DEPACKED PARTITIONS HEADER 
C 
C     ************************************************
C     *  N E X T    P A R T I T I O N   A D R E S S  *
C     ************************************************
C     * BIT EQT.* EXTENSION#    *   PARTITION SIZE   *
C     ************************************************
C     * BIT SWP.* PARTITION #   *   PROGRAM NUMBER   *
C     ************************************************
C 
      DIMENSION ITEMP(3)
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO 
     .             ,NCRTH(2490) 
C 
C     OFFSET CONSTANTS
C 
      IDISPL=260
      IOFST=2350+IREFC-NCRTH
      IF(IOFST.LT.IDISPL)  STOP 7010
C 
C     TRANSLATION INSIDE NCRTH TABLE
C 
      CALL MOVEW(NCRTH,NCRTH(IOFST+1),-NCRTH) 
      NCRTH(1+IOFST)=NCRTH(1+IOFST)+IOFST 
      DO 10 I=2,4 
      NCRTH(I+IOFST)=NCRTH(I)+IOFST 
10    CONTINUE
      J=NCRTH(4+IOFST)
20    IF(J.EQ.(NCRTH(1+IOFST)+1)) GOTO 30 
      NCRTH(J)=NCRTH(J)+IOFST 
      J=NCRTH(J)
      GOTO 20 
C 
C     INTERACTIVE LU# AND TYPES DILATATION
C 
30    INBLU=NCRTH(3)-NCRTH(2) 
      INDLU=NCRTH(3)
      CALL NUL(NCRTH(INDLU),(2*ILUGH)-INBLU)
C 
C     AUXILIARY LU# AND TYPES DILATATION
C 
      INBLU=NCRTH(4)-NCRTH(3) 
      INDLU=IREFC+ILUGH 
      INSLU=NCRTH(3)+IOFST
      CALL MOVEW(NCRTH(INSLU),NCRTH(INDLU),INBLU) 
C 
C     NEW HEADER ADRESSES 
C 
      NCRTH=ILGMX 
      NCRTH(2)=IREFC
      NCRTH(3)=NCRTH(2)+ILUGH 
      NCRTH(4)=NCRTH(3)+ILUGH 
C 
C     PARAMETERS INITIALISATION 
C 
      MM=0
      J=NCRTH(4+IOFST)
      ITEMP(1)=NCRTH(1+IOFST)+1 
      JJ=NCRTH(4) 
      KK=JJ+INTMS 
40    IF(J.EQ.ITEMP(1)) GOTO 300
      K=NCRTH(J)
      L=J+3 
      MM=MM+1 
      ITEMP(2)=NCRTH(J+1) 
      ITEMP(3)=NCRTH(J+2) 
C 
C     CALCULATES NUMBER OF TMS AND LIBRARIES
C 
      INBTS=(K-J-3)/3 
      INBLB=0 
      DO 60 NL=J+3,K-3,3
      IF(IAND(NCRTH(NL),100000B).NE.0) GOTO 70
60    CONTINUE
      GOTO 75 
70    INBTS=(NL-J-3)/3
      INBLB=(K-NL)/3
75    IF(INBLB/3.GE.INBTS/20) INBXT=INBLB/3 
      IF(INBLB/3.LT.INBTS/20) INBXT=INBTS/20
C 
C     PROGRAMS AND LIBRARIES GENERATION 
C 
      IX=INBXT
150   LL=(2*(JJ+3))-1 
      CALL BLAN(NCRTH,LL,ILPRG) 
      DO 80 IT=L,L+57,3 
      IF(INBTS.EQ.0) GOTO 85
      CALL MOVCA(NCRTH,((2*IT)-1),NCRTH,LL,5) 
      INBTS=INBTS-1 
      LL=LL+5 
80    CONTINUE
      L=L+60
85    NN=KK-9 
      DO 90 IL=NL,NL+6,3
      IF(INBLB.EQ.0) GOTO 95
      CALL MOVEW(NCRTH(IL),NCRTH(NN),3) 
      NCRTH(NN)=IAND(NCRTH(NN),77777B)
      INBLB=INBLB-1 
      NN=NN+3 
90    CONTINUE
      NL=NL+9 
95    ISWP=0
      IF(IAND(ITEMP(3),100000B).NE.0) ISWP=1
      ITEMP(3)=IAND(ITEMP(3),77777B)
      NCRTH(JJ+2)=(256*ITEMP(3))+MM 
      IF(ISWP.EQ.1) NCRTH(JJ+2)=IOR(NCRTH(JJ+2),100000B)
      IF(INBXT.EQ.0) INBXT=IX-1 
      NCRTH(JJ+1)=(256*(INBXT-IX+1))+ITEMP(2) 
      NCRTH(JJ)=KK
      JJ=KK 
      KK=KK+INTMS 
      IF(KK.GE.IT-3)    STOP 7012 
      IF(JJ.EQ.NCRTH+1) STOP 7013 
      IX=IX-1 
      IF(IX.NE.-1) GOTO 150 
      NCRTH(JJ-INTMS+1)=IOR(NCRTH(JJ-INTMS+1),100000B)
C 
C     CONTINUED 
C 
      J=K 
      GOTO 40 
300   NCRTH=JJ-1
      RETURN
      END 
      SUBROUTINE REPAK,92903-16405 REV.1913  781109 
C 
C 
C 
C     *********************************************** 
C     * THIS SUBROUTINE REPAKS THE NCRTH TABLE PRE- * 
C     * VIOUSLY DEPACKED BY DEPAK SUBROUTINE AND    * 
C     * MODIFIED BY THE INTERACTIVE PROCESS, IN OR- * 
C     * TO RE-BUILD THE "&XXXX" FILE FORMAT.        * 
C     *********************************************** 
C 
C     STOP USED:   7050 - 7052 - 7054 - 7056
C     ----------
C 
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO 
     .             ,NCRTH(2490) 
C 
      DIMENSION IBUFR(72) 
C 
      IDISPL=260
      KREFC=IREFC+2*ILUGH 
      LREFC=2130+IREFC
C 
C     LU AREA 
C 
C#####################################################################
C 
C     PRINT-OUT TUS AREA !
C 
D     KKK=NCRTH(4)
D     KKN=NCRTH+1 
D     WRITE(6,8971)KKN
D8971 FORMAT(2/,"  REPACK PRINT-OUT: NCRTH+1 ="I5)
D     KKL=KKK 
D8973 WRITE(6,8974)KKL,NCRTH(KKL) 
D8974 FORMAT(20X"ADDR:"I5"   CONTENT:"I5) 
D     KKL=NCRTH(KKL)
D     IF(KKL .NE. 0)  GOTO 8973 
D     DO 8978 KKL=KKK,KKN,INTMS 
D     KKO=IAND(NCRTH(KKL+2),177B) 
D     KKM=2HLS
D     IF(IAND(NCRTH(KKL+1),100000B).EQ.0) KKM=2HEX
D     WRITE(6,8976)KKM,KKO,KKL,(NCRTH(II),II=KKL,KKL+61)
D8976 FORMAT(10X,A2"T OF UPT #"I3,3X, 
D    ." ADDR ="I5,": VAL ="I5,2@10,/,10X," ["30A2,/,10X," ",29A2"]")
D8978 CONTINUE
C#####################################################################
      CALL ISPRZ(NCRTH(IREFC),ILUGH,NLE)
      NCRTH(3)=IREFC+NLE
      CALL ITRIC(NCRTH(IREFC),ILUGH,2)
      CALL CLSLU(NCRTH(IREFC),ILUGH)
      CALL ISPRZ(NCRTH(IREFC+ILUGH),ILUGH,NLE)
      CALL ITRIC(NCRTH(IREFC+ILUGH),ILUGH,2)
      CALL CLSLU(NCRTH(IREFC+ILUGH),ILUGH)
      CALL MOVEW(NCRTH(IREFC+ILUGH),NCRTH(NCRTH(3)),NLE)
      NCRTH(4)=NCRTH(3)+NLE 
C 
C     PROGRAM EXTENSIONS GROUPING AND CLASSING
C 
11    DO 14 I=KREFC+2,ILGMX-(2*INTMS)+2,INTMS 
      IPRGA=(IAND(NCRTH(I),177B)) 
      IPRGB=(IAND(NCRTH(I+INTMS),177B)) 
      IF(IPRGA.EQ.0 .AND. IPRGB.EQ.0)  GOTO 15
      IF(IPRGA.EQ.0)  GOTO 12 
      IF(IPRGA.LE.IPRGB) GOTO 14
      IF(IPRGB.EQ.0) GOTO 14
12    CALL MOVEW(NCRTH(I-2),IBUFR,INTMS)
      CALL MOVEW(NCRTH(I-2+INTMS),NCRTH(I-2),INTMS) 
      CALL MOVEW(IBUFR,NCRTH(I-2+INTMS),INTMS)
      GOTO 11 
14    CONTINUE
C 
C     TRANSFER TMS & LIBRARY AT THE NCRTH BOTTOM
C 
15    CONTINUE
C#####################################################################
C 
C     RE-PRINT-OUT TUS AREA ! 
C 
D     KKN=NCRTH+1 
D     WRITE(6,8981)KKN
D8981 FORMAT(2/,"  REPACK PRINT-OUT: (AFTER SORTING)  NCRTH+1 ="I5) 
D     KKL=KKK 
D8983 WRITE(6,8984)KKL,NCRTH(KKL) 
D8984 FORMAT(20X"ADDR:"I5"   CONTENT:"I5) 
D     KKL=NCRTH(KKL)
D     IF(KKL .NE. 0)  GOTO 8983 
D     DO 8988 KKL=KKK,KKN,INTMS 
D     KKO=IAND(NCRTH(KKL+2),177B) 
D     KKM=2HLS
D     IF(IAND(NCRTH(KKL+1),100000B).EQ.0) KKM=2HEX
D     WRITE(6,8976)KKM,KKO,KKL,(NCRTH(II),II=KKL,KKL+61)
D8988 CONTINUE
C#####################################################################
C 
C-----DISPLACE EVERYTHING BY 'IDISPL' WORDS FORWARD WITH A MOVE 
C 
      CALL MOVEW(NCRTH(KREFC),NCRTH(KREFC+IDISPL),-1613)
      NCRTH=NCRTH+IDISPL
C 
C     RESTORE NCRTH LINK
C 
      DO 18 I=KREFC+IDISPL,NCRTH+1-INTMS,INTMS
      NCRTH(I)=I+INTMS
18    CONTINUE
C 
C     PROGRAMS
C 
      J=KREFC+IDISPL
      JJ=NCRTH(4) 
20    LL=JJ 
      L=J 
      IEXTN=0 
      IF(J.EQ.NCRTH+1) GOTO 100 
      IF(IAND(NCRTH(J+1),77600B).NE.0) IEXTN=1
C 
C     SAVE LIBRARIES & HEADERS OF CURRENT PROGRAM 
C 
      I=LREFC 
      CALL BLANC(NCRTH(I),300)
      LLLL=L
200   CALL MOVEW(NCRTH(LLLL),NCRTH(I),3)
      I=I+3 
      LLLL=LLLL+INTMS-9 
      CALL MOVEW(NCRTH(LLLL),NCRTH(I),9)
      K=LLLL+9
      IF(IAND(NCRTH(LLLL-INTMS+10),100000B).NE.0) GOTO 25 
      LLLL=LLLL+9 
      I=I+9 
      IF(I-LREFC .GE. 295) STOP 7050
      GOTO 200
C 
C     TMS-SUBROUTINES 
C 
25    DO 30 I=(2*(J+3))-1,(2*(J+3))-1+96,5
      IF(IGET1(NCRTH,I).NE.1H ) GOTO 27 
      IF(IEXTN.NE.1) GOTO 40
      GOTO 31 
27    CALL MOVCA(NCRTH,I,NCRTH,(2*(JJ+3))-1,5)
      CALL PUTCA(NCRTH,1H ,(2*(JJ+3))+4)
      JJ=JJ+3 
      IF(JJ+3.GE.((I+1)/2)-3) STOP 7052 
30    CONTINUE
31    IF(IAND(NCRTH(J+1),100000B).NE.0) GOTO 40 
      J=NCRTH(J)
      IF(J.EQ.NCRTH+1) GOTO 40
      GOTO 25 
C 
C     LIBRARIES 
C 
40    J=LREFC 
      L=J 
45    DO 50 I=J+3,J+3+6,3 
      IF(NCRTH(I).NE.2H  ) GOTO 70
      IF(IEXTN.NE.1) GOTO 60
      GOTO 51 
70    CALL MOVEW(NCRTH(I),NCRTH(JJ+3),3)
      NCRTH(JJ+3)=IOR(NCRTH(JJ+3),100000B)
      JJ=JJ+3 
      IF(JJ+3.GE.K) STOP 7054 
50    CONTINUE
51    IF(IAND(NCRTH(J+1),100000B).NE.0) GOTO 60 
      IF(NCRTH(J).EQ.NCRTH+1) GOTO 60 
      J=J+12
      GOTO 45 
C 
C     PROCESS HEADER AND THEN GO TO NEXT PROGRAM
C 
60    JJ=JJ+3 
      IF(JJ+3.GE.K) STOP 7056 
      NCRTH(LL)=JJ
      NCRTH(LL+1)=IAND(NCRTH(J+1),177B) 
C 
C     SWAPPING BIT
C 
      ISWP=0
      IF(IAND(NCRTH(L+2),100000B).NE.0) ISWP=1
      NCRTH(LL+2)=(IAND(NCRTH(L+2),77600B))/256 
      IF(ISWP.EQ.1) NCRTH(LL+2)=IOR(NCRTH(LL+2),100000B)
      J=K 
C 
C     IS IT A TRUE PROGRAM ?
C 
      IF(JJ.NE.LL+3) GOTO 700 
      JJ=JJ-3 
700   IF(J.NE.NCRTH+1) GOTO 20
100   NCRTH=JJ-1
C 
      RETURN
      END 
      SUBROUTINE CLSLU(IBUF,LEN),92903-16405 REV.1913  790130 
C 
C 
C 
C     ********************************************
C     * THIS SUBROUTINE LOOKS FOR LU# OF THE SA- *
C     * ME TYPE IN AN ALREADY ORDERED AREA, THEN *
C     * CLASS THEM IN AN INCREASING ORDER.       *
C     *                                          *
C     *   CALL CLSLU(P1,P2)                      *
C     *                                          *
C     *   P1 = NAME(I) OF THE AREA TO PROCESS    *
C     *        I POINTS AT THE FIRST LU#         *
C     *   P2 = LENGTH OF THIS AREA               *
C     ********************************************
C 
C 
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IDUM0(7),NCRTH(1) 
C 
      DIMENSION IBUF(1) 
C 
C 
      J=1 
      DO 10 I=2,LEN-2,2 
      IF(IBUF(I).EQ.IBUF(I+2)) GOTO 10
      IF(I-J.GE.3) GOTO 20
      J=I+1 
      GOTO 10 
20    CALL ITRIC(IBUF(J),I-J+1,1) 
      J=I+1 
10    CONTINUE
      RETURN
      END 
      SUBROUTINE ISPRZ(IBUF,LEN,NLE),92903-16405 REV.1913  790130 
C 
C 
C     ******************************************* 
C     * THIS SUBROUTINE ELIMINATES ALL THE LU#  * 
C     * WHICH ARE EQUAL TO "00" IN THE PRECISED * 
C     * AREA.                                   * 
C     *                                         * 
C     *  CALL ISPRZ(P1,P2,P3)                   * 
C     *                                         * 
C     *  P1 = NAME(I) OF THE AREA TO PROCESS    * 
C     *       I POINTS AT THE THE FIRST LU#     * 
C     *  P2 = WORD LENGTH OF THE AREA           * 
C     *  P3 = WORD LENGTH AFTER COMPRESSION     * 
C     ******************************************* 
C 
C 
C 
      DIMENSION IBUF(1) 
C 
C 
      NLE=LEN 
      K=0 
      I=1 
10    IF(IBUF(I).EQ.0) GOTO 40
20    I=I+2 
      IF(I.LE.NLE-1) GOTO 10
30    DO 35 L=NLE+1,NLE+K 
      IBUF(L)=32767 
35    CONTINUE
      RETURN
40    J=I 
      KK=0
50    KK=KK+2 
      J=J+2 
      IF(J.GT.NLE-1) GOTO 60
      IF(IBUF(J).EQ.0) GOTO 50
      CALL MOVEW(IBUF(J),IBUF(I),NLE-J+1) 
60    NLE=NLE-KK
      K=K+KK
      GOTO 20 
      END 
      SUBROUTINE ITRIC(IBUF,LEN,IORG),92903-16405 REV.1805  780109
C 
C 
C 
C     *********************************************** 
C     * THIS SUBROUTINE CLASS IN AN INCREASING OR-  * 
C     * DER THE LU-TYPE NCRTH AREA.                 * 
C     *                                             * 
C     *  CALL ITRIC(P1,P2,P3)                       * 
C     *                                             * 
C     *  P1 = NAME(I) OF THE AREA TO PROCESS        * 
C     *       I POINTS AT THE FIRST LU#             * 
C     *  P2 = LENGTH OF THE AREA TO BE ORDERED      * 
C     *  P3 = FUNCTION:   1 ORDERS LU#              * 
C     *                   2 ORDERS TYPE             * 
C     *********************************************** 
C 
C 
C 
      DIMENSION IBUF(1) 
C 
C 
C 
      DO 20 I=IORG,LEN+IORG-4,2 
10    IF(IBUF(I).LE.IBUF(I+2)) GOTO 20
      ITLU=IBUF(I-IORG+1) 
      ITYP=IBUF(I-IORG+2) 
      IBUF(I-IORG+1)=IBUF(I-IORG+3) 
      IBUF(I-IORG+2)=IBUF(I-IORG+4) 
      IBUF(I-IORG+3)=ITLU 
      IBUF(I-IORG+4)=ITYP 
      IF(I.EQ.IORG) GOTO 20 
      I=I-2 
      GOTO 10 
20    CONTINUE
      RETURN
      END 
      FUNCTION NBUPT(NCRTH),92903-16405 REV.1805  780104
C 
C     ************************************************* 
C     * THIS FUNCTION RETURN THE NUMBER OF USER       * 
C     * PARTITION ENTERING IN AN APPLICATION.         * 
C     ************************************************* 
C 
C     NOTE: THIS SUBROUTINE WORKS ON THE PACKED FORMAT OF NCRTH 
C     -----                              ------ 
C 
C 
      DIMENSION NCRTH(1)
C 
      M=0 
      J=NCRTH(4)
100   K=NCRTH(J)
      M=M+1 
      J=K 
      IF(K .NE. NCRTH+1) GOTO 100 
      NBUPT=M 
      RETURN
      END 
      END$