FTN4
C 
C 
C     NAME:   CTILU,LOOLU,DPILU,DUPLU,LCKLU,TMPRS,DUPNA,
C                   CTRAC,ORDLU 
C     SOURCE: &TMGL5    92080-18404 
C     BINARY: %TMGL5    92080-1X404    PART OF  $TMGL1
C 
C     PRGMR:  FRANCOIS GAULLIER   HPG 
C 
C 
C     **************************************************************
C     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  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 
      SUBROUTINE CTILU,92080-1X404 REV.2026  790613 
C 
C 
C     THIS SUBROUTINE TRANSLATES NCRTH(50) INTO NCRTH(2000) 
C     IN ORDER TO BE DISPLAYABLE ON SCREEN NUMBER 1 (LU DEFINITION
C     SCREEN) 
C     THE ROUTINE 'DPILU' DOES THE REVERSE THING. 
C 
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO 
     .             ,NCRTH(1)
C 
      IDECLW=(IDECL+2)/2
C 
      J=IDECLW
      CALL NUL(NCRTH(J),192)
      K=IREFC 
      DO 10 I=IREFC,IREFC+ILUGH-4,2 
      IZZ=I+1 
      IF(NCRTH(I+1).EQ.NCRTH(I+3).AND.NCRTH(I+2).EQ.(NCRTH(I)+1)) 
     .GOTO 20 
      GO TO 21
20    IF(NCRTH(I+1).EQ.10000)NCRTH(I+1)=0 
      GO TO 10
21    IF(NCRTH(I+1).EQ.10000)NCRTH(I+1)=0 
      NCRTH(J)=NCRTH(K) 
      NCRTH(J+1)=NCRTH(I) 
      IF(NCRTH(J+1).EQ.NCRTH(J)) NCRTH(J+1)=0 
      NCRTH(J+2)=NCRTH(I+1) 
      NCRTH(J+3)=0
      K=I+2 
      J=J+4 
10    CONTINUE
      RETURN
      END 
      LOGICAL FUNCTION LOOLU(IADS,ILUB,IPTR,NUERO 
     .,IBUFR),92080-1X404 REV.2026  790307
C 
C     FUNCTION TO FIND DUPLICATE LUS
C 
C     FUNCTION IS  FALSE  IF THE LU TO BE CHECKED (ILUB) IS NOT 
C     ALREADY AN INTERACTIVE OR AUXILIARY DEVICE. 
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO 
     .             ,NCRTH(1)
      DIMENSION IBUFR(1)
C 
C 
C     IADS=WORD NCRTH ADRESS
C     ILUB=LU# TO CHECK 
C     IPTR=FIELD POINTER
C     NUERO=RETURNED ERROR MESSAGE NUMBER 
C     IBUFR=CURRENT BUFFER
C 
C 
      ITRU=0
      NUERO=0 
      ITOP=IREFC+ILUGH
      LOOLU=.FALSE. 
      DO 10 I=IREFC,ITOP-2,2
      IF(NCRTH(I).EQ.ILUB) ITRU=1 
10    CONTINUE
      IF(ITRU.EQ.0) GOTO 15 
      NUERO=12
      GOTO 40 
15    IF(IADS.EQ.ITOP) GOTO 25
      DO 20 I=ITOP,IADS-2,2 
      IF(NCRTH(I).EQ.ILUB) ITRU=1 
20    CONTINUE
25    IF(IPTR.EQ.1) GOTO 35 
      DO 30 I=1,IPTR-2,2
      IF(IBUFR(I).EQ.ILUB) ITRU=1 
30    CONTINUE
35    IF(ITRU.EQ.0.AND.IBUFR(I+1).EQ.-1) NUERO=11 
      IF(ITRU.EQ.1.AND.IBUFR(I+1).NE.-1) NUERO=8
40    IF(NUERO.NE.0) LOOLU=.TRUE. 
      RETURN
      END 
      SUBROUTINE DPILU,92080-1X404 REV.2026  790613 
C 
C  THIS SUBROUTINE DEPACKS THE INTERACTIVE LU BUFFER IN NCRTH(2050) 
C     AND THEN TRANSLATES NCRTH(2050) INTO NCRTH(50), ITS FINAL PLACE.
C 
C  THIS ROUTINE IS ONLY USED IN THE INTERACTIVE LU PROCESS. 
C                                   --------------
C 
C  THE ROUTINE 'CTILU' DOES THE REVERSE THING.
C 
C   CONCEIVED AND ORIGINALLY WRITTEN BY FRANCOIS GAULLIER, HPG
C     REDESIGNED FOR 'DATACAP-B' BY STEVE WITTEN, DSD 
C 
C  LABELED COMMON # 3   BUFFER AREA 
C 
      COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO,NCRTH(1)
C 
C 
      DIMENSION IDPAK(260),ITEMP(260) 
C 
C 
      IDECLW=(IDECL+2)/2
C 
      ILEGH=260 
C 
C  DEPACK NCRTH(IDELCW) INTO IDPAK(1) 
C 
      CALL NUL(IDPAK,ILEGH) 
      CALL NUL(ITEMP,ILEGH) 
      J=1 
      DO 30 I=IDECLW,IDECLW+192-4,4 
      IF(NCRTH(I).EQ.0.AND.NCRTH(I+1).EQ.0)GO TO 31 
      IF(NCRTH(I).NE.NCRTH(I+1))GO TO 45
      IDPAK(J)=NCRTH(I) 
      IDPAK(J+1)=NCRTH(I+2) 
      IDPAK(J+2)=NCRTH(I+3) 
      GO TO 29
45    L=J 
      M=NCRTH(I)
      IED=J+(NCRTH(I+1)-NCRTH(I))*3 
      DO 10 N=L,IED,3 
      IDPAK(N)=M
      IDPAK(N+1)=NCRTH(I+2) 
      IDPAK(N+2)=NCRTH(I+3) 
      M=M+1 
10    J=J+3 
      GO TO 30
29    J=J+3 
30    CONTINUE
31    CONTINUE
C 
C  DELETE LU'S MARKED WITH -1 IN THIRD WORD OF TRIPLE 
C 
C             << LU#, TS# ASSIGNED, KEEP OR DELETE >> 
C 
C  N.B.  "KEEP" IS MARKED BY BLANK
C        "DELETE" IS MARKED BY -1 
C 
      DO 35 N=1,ILEGH,3 
      IF(IDPAK(N+2).EQ.-1)GO TO 38
C 
C  FOUND AN LU TO KEEP
C 
      GO TO 35
C 
C  FOUND AN LU TO DELETE -- CHANGE KEEP CODE TO DELETE CODE 
C 
38    CONTINUE
      DO 37 M=1,N,3 
37    IF(IDPAK(M).EQ.IDPAK(N))IDPAK(M+2)=-1 
35    CONTINUE
C 
C  DELETE ALL LU TRIPLES WITH DELETE CODE OF -1 
C    AND CHANGE ALL KEEP CODES TO ZERO
C 
      DO 54 K=1,ILEGH,3 
      IF(IDPAK(K+2).EQ.-1)CALL NUL(IDPAK(K),3)
54    IF(IDPAK(K+2).EQ.2H  )IDPAK(K+2)=0
C 
C  NULL OUT THE RECEIVING BUFFER
C 
      CALL NUL(NCRTH(IREFC),ILUGH)
C 
C  CONTRACT THE LU BUFFER 
C 
      J=1 
      DO 58 K=1,ILEGH 
      IF(IDPAK(K).EQ.0)GO TO 58 
      ITEMP(J)=IDPAK(K) 
      J=J+1 
58    CONTINUE
C 
C  MOVE THE TEMP. BUFFER (WITH NO ZEROS) BACK TO 'IDPAK'
C 
      CALL MOVEW(ITEMP,IDPAK,ILEGH) 
C 
C  CONTRACT THE LU BUFFER 
C 
      CALL ISPRZ(IDPAK,ILEGH,LEN) 
C 
C  MOVE THE LU BUFFER TO THE RECEIVING BUFFER 
C 
      CALL MOVEW(IDPAK,NCRTH(IREFC),LEN)
C 
C  ... AND RETURN 
C 
      RETURN
      END 
      SUBROUTINE DUPLU(IBUF,LEN,IFILD,LUER),92080-1X404 REV.2026  790613
C 
C 
C     THIS SUBROUTINE LOOK FOR DUPLICATE INTERACTIVE LU#
C     IFILD = RETURNED FIELD NUMBER 
C     LUER  = DEFECTIVE LU# (ASCII) 
C     LUER= [] : LUS<LU1  LU2<LUL 
C 
C 
      DIMENSION IBUF(1) 
      LOGICAL ISBTW 
C 
      LUER=0
      ISZSC=64
      IBRNF=LEN-(ISZSC/2)+1 
      IBRNS=LEN 
      IFILD=1 
      IF(LEN.NE.(ISZSC/2)) GOTO 4 
      IFILD=IFILD+4 
      IBRNF=IBRNF+4 
C 
C     #   LU FORM OF LINE I 
C     *   LU TO   OF LINE I 
C     [   LU FROM OF LINE K (K=1 TO I-1)
C     ]   LU TO   OF LINE K (K=1 TO I-1)
C 
C   +--------------------+
C   * I   I+1    K   K+1 *
C   * .    .     .    .  *
C   * #    *     [    ]  *
C   +--------------------+
C 
C     CHECK LAST RECEIVE LU # SCREEN
C 
4     DO 100 I=IBRNF,IBRNS,4
      IPOS=0
      IF(IBUF(I+1).EQ.0.AND.IBUF(I).EQ.0) GOTO 90 
C 
C     ANALYSE RELATIVE POSITIONS OF # * [ ] 
C 
C   +-----------------------+ 
C   * IPOS = 1 ---->  #*[]  * 
C   * IPOS = 2 ---->  #[*]  * 
C   * IPOS = 3 ---->  [#*]  * 
C   * IPOS = 4 ---->  [#]*  * 
C   * IPOS = 5 ---->  []#*  * 
C   * IPOS = 6 ---->  #[]*  * 
C   +-----------------------+ 
C 
C     CHECK LINE: I AGAINST ALL PREVIOUS LINES
C 
      DO 10 K=1,I-4,4 
      ITR1=0
      ITR2=0
      ITR3=0
      ITR4=0
      IF(IBUF(I+1).EQ.0) IBUF(I+1)=IBUF(I)
      IF(IBUF(K+1).EQ.0) IBUF(K+1)=IBUF(K)
C 
C-----* [ ] ?   ITR1
C 
      IF(IBUF(I+1).LT.IBUF(K)) ITR1=1 
C 
C-----[ * ] ?   ITR2
C 
      IF(.NOT.ISBTW(IBUF(I+1),IBUF(K),IBUF(K+1))) ITR2=1
C 
C-----[ # ] ?   ITR3
C 
      IF(.NOT.ISBTW(IBUF(I),IBUF(K),IBUF(K+1))) ITR3=1
C 
C-----[ ] # ?   ITR4
C 
      IF(IBUF(I).GT.IBUF(K+1)) ITR4=1 
C 
C     LOOK FOR FIRST LU# INCLUDED, IF REQUIRED
C 
      IF(ITR2.EQ.1) CALL LCKLU(K,I+1,K+1,IBUF,LUER) 
      IF(ITR3.EQ.1) CALL LCKLU(K,I,K+1,IBUF,LUER) 
C 
C     CALCULATES IPOS 
C 
      IF(ITR1.EQ.1.AND.ITR3+ITR4.EQ.0) IPOS=1 
      IF(ITR2.EQ.1.AND.ITR3+ITR4.EQ.0) IPOS=2 
      IF(ITR2.EQ.1.AND.ITR3.EQ.1) IPOS=3
      IF(ITR3.EQ.1.AND.ITR1+ITR2.EQ.0) IPOS=4 
      IF(ITR4.EQ.1.AND.ITR1+ITR2.EQ.0) IPOS=5 
      IF(ITR1+ITR2.EQ.0.AND.ITR3+ITR4.EQ.0) IPOS=6
      IF(IPOS.EQ.0) STOP 6001 
C 
C     VERIFY CORRECT DEFINITION 
C 
      IF(IBUF(I+3).EQ.-1.AND.IBUF(K+3).NE.-1) GOTO 7
C 
C     NO DELETE IS INVOLVE IN THE CURRENT LINE  I 
C     CHECK FOR DUPLICATE LU'S
C 
      IF(IPOS.EQ.2) GOTO 30 
      IF(IPOS.EQ.4) GOTO 40 
      IF(IPOS.EQ.3) GOTO 40 
      IF(IPOS.EQ.6) GOTO 20 
      LUER=0
      GOTO 10 
C 
C     A DELETE IS REQUESTED IN THE CURRENT LINE 
C     IF LU FOUND THEN GO TO NEXT LINE I
C 
7     CONTINUE
      IF(IPOS .EQ. 3)  GOTO 100 
C-----DELETE BUT THE LU IS NOT YET FOUND, CONTINUE
10    CONTINUE
C-----IF DELETE, THE LU HAS NEVER BEEN FOUNDED, ERROR ! 
      IF(IBUF(I+3) .EQ.-1)  GOTO 50 
C 
C     CHECK LINE I AGAINST NEXT ONE 
C 
90    IFILD=IFILD+4 
      LUER=0
C 
C     LINE I HAS BEEN CHECK AGAINST ALL PREVIOUS LINE,
C     GO TO NEXT LINE I 
C 
100   CONTINUE
      LUER=0
      RETURN
C 
20    LUER=2H[] 
      RETURN
C 
C     DUPLICATE LU'S  (THE 'TO' LU IS DUPLICATED) 
C 
30    IFILD=IFILD+1 
40    RETURN
C 
C     ERROR "UNDEFINED LU" USED IN CASE OF DELETE 
C 
50    IF(IPOS.EQ.4) IFILD=IFILD+1 
      LUER=-1 
      RETURN
      END 
      SUBROUTINE LCKLU(IBRN1,IBRN2,IBRN3,IBUF 
     .,LUER),92080-1X404 REV.2026  790307 
C 
C 
C     THIS SUBROUTINE SEARCH FOR THE LU : IBUF(IBRN2) 
C     WHITCH IS BETWEEN IBUF(IBRN1),IBUF(IBRN3) 
C 
C 
      DIMENSION IBUF(1),NUMB(3) 
C 
      LUER=2H99 
      LUTST=IBUF(IBRN1) 
      DO 20 I=1,IBUF(IBRN3)-IBUF(IBRN1)+1 
      IF(IBUF(IBRN2).NE.LUTST) GOTO 10
      CALL CNUMD(LUTST,NUMB)
      LUER=NUMB(3)
      RETURN
10    LUTST=LUTST+1 
20    CONTINUE
      RETURN
      END 
      LOGICAL FUNCTION TMPRS(IOFST,LENGH,ISUPT,IEND 
     .,IFILD),92080-1X404 REV.2026  800415
C 
C 
C     ***************************************************************** 
C     *                                                               * 
C     * THIS LOGICAL FUNCTION PROCESS SCREEN # 3. THIS FUNCTION       * 
C     * WORKS ON THE UNPACKED FORM OF NCRTH.                          * 
C     *              --------                                         * 
C     *                                                               * 
C     *   IF( TMPRS(IOFST,LENGH,IUPT,IEND,IFILD) )  GOTO ERROR        * 
C     *                                                               * 
C     *             IOFST - OFSET IN BYTE INTO NCRTH (USED BY 'MOVCX' * 
C     *                     TO DISPLAY THE SCREEN.)                   * 
C     *                     IF = 0  ---> INIT LOCAL VARIABLE & RETURN * 
C     *             LENGH - LENGH OF THE INPUT (T LOG)                * 
C     *             IUPTN - FIRST U.P.T. TO BE DISPLAYED.             * 
C     *             IEND  - RETURN PARAMETERS (END INDICATOR OR ERROR * 
C     *                     NUMBER.)                                  * 
C     *             IFILD - FIELD ERROR ON THE SCREEN OF THE ERROR    * 
C     *                                                               * 
C     * IF IOFST IS NOT 0, THE CURRENT SCREEN IS ANALYSED, AND TMPRS  * 
C     * RETURN THE NEXT STEP TO EXECUTE USING  IEND & IFILD           * 
C     *                                                               * 
C     * IF A SCREEN IS NOT FULL AND NO ERROR IS FOUND, IT IS CONSI-   * 
C     * DERED THE LAST FOR THAT U.P.T. AND TMPRS SWITCH TO THE NEXT   * 
C     * U.P.T.                                                        * 
C     * IF A SCREEN IS FULL AND NO ERROR IS FOUND, TMPRS GENERATES    * 
C     * AN EXTENSION FOR THAT U.P.T. AND CONTINUE.                    * 
C     * IF A SCREEN IS EMPTY, TMPRS RETURN THE END INDICATOR = 1 TO   * 
C     * INDICATE END OF U.P.T. DEFINITION PROCESSING.                 * 
C     *                                                               * 
C     ***************************************************************** 
C 
C 
C     VALUE RETURNED BY IEND
C 
C         - END INDICATOR:   0  - CONTINUE CURRENT PROCESS (DISPLAY 
C                                 THE SCREEN) 
C                            1  - END OF CURRENT PROCESS
C                            2  - ABORT THE PROGRAM 
C                            3  - GO TO PREVIOUS SCREEN 
C 
C         - ERROR VALUE:    13  - PARTITION REQUIREMENT TOO BIG 
C                           14  - ILLEGAL PARTITION NUMBER
C                           15  - DUPLICATE T.U.S.
C                           16  - NO T.U.S. DEFINED AT ALL
C                           17  - TOO MANY T.U.S., LIBRARY OR U.P.T.
C                           18  - ILLEGAL NAME FOR T.U.S. OR LIBRARY
C                           19  - SWAPPING OPTION ANSWER MUST BE 'X'
C                           20  - NO LIBRARY ALLOWED IF NO T.U.S. DEFINED 
C                           34  - ILLEGAL CHARACTER 
C 
C-----LABEL COMMON # 1  TERMINAL LU 
C 
      COMMON /TMGC1/LU
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO 
     .             ,NCRTH(2100),IEXFL,IPTR,NBSCR,IFSCR,ILAST
     .             ,IFLG(29),IPRVS(29),IBUFR(62),ITEMP(3),ITOSC 
C 
C-----LABEL COMMON # 4  I/O BUFFER (MAX SIZE = 100 WORDS) 
C 
      COMMON /TMGC4/IOBUF 
C 
      LOGICAL JPAR,KPAR,IMBED,DUPNA,CMPB,OKABT,FSCRN,ISSPA
      LOGICAL PSFLG,INSFLG,IEXFL
C 
C 
C     ILAST  - POINT ON THE LAST SCREEN OF THE LAST PROGRAM,
C              WHICH IS NOT ALWAYS THE LAST PHYSICAL BUFFER IN
C              NCRTH. 
C 
      KPAR(IP1,IP2)=JPAR(IOBUF,LENGH,I,ITEMP,IP1,IFLG(I),IP2) 
      FSCRN(IP3)=IAND(NCRTH(IPTR+1),77600B).NE.256 .AND.
     .  IAND(NCRTH(IPTR+1),77600B).NE.0 
C 
      TMPRS=.FALSE. 
      ISTAR=((IREFC+2*ILUGH)*2)-2 
      IEXFL=.FALSE. 
      IF(IOFST.NE.0) GOTO 20
C 
C     FIRST TIME TMPRS IS CALLED
C 
      IEND=0
      NBSCR=1 
      IFSCR=1 
      ILAST=NCRTH+1-INTMS 
      IOFST=ISTAR 
      IPTR=(ISTAR+2)/2
      ITOSC=1+(ILAST-IPTR)/INTMS
C-----SEARCH THE RIGHT UPT #
13    I=IAND(NCRTH(IPTR+2),177B)
      IF(I .GE. ISUPT)  GOTO 148
C-----SEARCH THE FIRST SCREEN OF THE RIGHT UPT IN THE CHAIN 
15    J=IAND(NCRTH(IPTR+1),100000B) 
      NBSCR=NBSCR+1 
      IFSCR=IFSCR+1 
      IF(NCRTH(IPTR) .EQ. NCRTH+1)  GOTO 165
      IPTR=NCRTH(IPTR)
      IOFST=(2*IPTR)-2
      IF(J .EQ. 0)  GOTO 15 
      GOTO 13 
C 
C     PROCESS A SCREEN # 3 (DEFINITION OF T.U.S.) 
C 
20    CALL NUL(IBUFR,INTMS) 
      PSFLG=.FALSE. 
      INSFLG=.FALSE.
      IEND=0
C 
C     T.U.S. / LIBRARY  ACQUISITION 
C 
      NUERO=18
      J=5 
      K=7 
      DO 30 I=1,23
      IF(I .EQ. 21)  J=6
      CALL BLANC(ITEMP,3) 
      IF( KPAR(J,IJK) )   GOTO 200
      IF(IFLG(I).NE.0 .AND. IFLG(I).NE.3) GOTO 400
      IF( IMBED(ITEMP,1,J) )  GOTO 400
      CALL ISUPB(ITEMP,3) 
      CALL MOVCA(ITEMP,1,IBUFR,K,J) 
28    K=K+J 
30    CONTINUE
C 
C     PARTITION SIZE ACQUISITION (ONLY IF LENGH IS OK)
C 
      I=24
      IF( KPAR(2,IBUFR(2)) )  GOTO 198
      NUERO=13
      IF(IFLG(I).NE.0 .AND. IFLG(I).NE.1) GOTO 400
      IF(IBUFR(2) .GE. 30)  GOTO 400
C 
C     PARTITION NUMBER ACQUISITION (ONLY IF LENGH IS OK)
C 
40    I=25
      IF( KPAR(2,IBUFR(3)) )  GOTO 198
      NUERO=14
      IF(IFLG(I).NE.0 .AND. IFLG(I).NE.1) GOTO 400
      IF(IBUFR(3) .GT. 63) GOTO 400 
      IBUFR(3)=(256*IBUFR(3)) 
C 
C     SWAPPING BIT (ONLY IF LENGH IS OK)
C 
50    I=26
      ITEMP=2H
      IF( KPAR(1,IJK) )   GOTO 198
      NUERO=19
      IF(IFLG(I).NE.0 .AND. IFLG(I).NE.3) GOTO 400
      IF(ITEMP.EQ.2HX ) IBUFR(3)=IOR(IBUFR(3),100000B)
C-----THE ENTIRE SCREEN HAS BEEN CHECK, FUNCTION ?
80    IF( INSFLG )  GOTO 380
      IF( PSFLG  )  GOTO 135
C 
C     NO SPECIAL FUNCTION, EMPTY SCREEN ? 
C 
      DO 110 I=1,23 
      IF(IFLG(I).NE.0) GOTO 130 
110   CONTINUE
C 
C     YES, IT IS AN EMPTY SCREEN, IT IS THE END OF T.U.S. DEFINITION
C 
      IF(NCRTH(IPTR) .NE. NCRTH+1) GOTO 132 
C-----IF AN EXTENSION SCREEN, GO GET A NEW UPT
      IF( FSCRN(I) )  GOTO 165
      NUERO=16
      IF(IOFST .EQ. ISTAR)  GOTO 398
      CALL NUL(NCRTH(IPTR),INTMS) 
      NCRTH=NCRTH-INTMS 
      IEND=1
      GOTO 149
C 
C     SET UP TO GO TO A NEXT SCREEN (EXTENSION OR NEW UPT)
C     (SUPPRESS BLANK FIELD IN THAT SCREEN) 
C 
C     THE NEXT 15 LINES WERE RE-DONE FOR THE 2026 PCO TO CORRECT
C     MISPLACED ERROR MESSAGE CURSOR RETURNS
C 
C-----NO LIBRARY ALLOWED IF NO T.U.S. DEFINED 
130   NUERO=20
      IF(.NOT.ISSPA(IBUFR,7,100).AND. ISSPA(IBUFR,107,18) ) GOTO 398
C-----STORE DATA BACK INTO  NCRTH 
132   IPTR2=IPTR
      CALL MOVEW(IBUFR(4),NCRTH(IPTR+3),INTMS-3)
C-----CHECK FOR DUPLICATE T.U.S.
      NUERO=15
      IF( .NOT. DUPNA(IPTR,I) )  GOTO 400 
      CALL CTRAC(IBUFR,K) 
      IPTR=IPTR2
      CALL MOVEW(IBUFR(4),NCRTH(IPTR+3),INTMS-3)
C 
C---  NOW CHECK FOR DUPLICATE LIBRARY NAMES IN IBUFR. BUG FIX FOR 
C     PCO 2026 BJH. 
C 
      IF(.NOT.CMPB(IBUFR,107,IBUFR,113,6) .OR.
     .  (.NOT.ISSPA(IBUFR,107,12))) GO TO 133 
      NUERO=52
      IFILD=21    
      GO TO 400 
133   CONTINUE
C 
C 
C-----KEEP TRACK OF WHERE THE DATA ARE SAVED FOR "PREVIOUS SCREEN" KEY
      IPRVS(NBSCR)=IOFST
      IF(NBSCR .LT. 27)  NBSCR=NBSCR+1
C     IF(NBSCR .LT. 26)  NBSCR=NBSCR+1       MAY BE THIS IS CORRECT !!! 
C 
C     FIRST SCREEN FOR A UPT ?
C 
135   IF( FSCRN(I) )  GOTO 140
C-----YES, 1ST SCREEN, SET UP PARTITION SIZE AND PARTITION NUMBER 
      NCRTH(IPTR+1)=IBUFR(2)+IAND(NCRTH(IPTR+1),177600B)
      NCRTH(IPTR+2)=IBUFR(3)+IAND(NCRTH(IPTR+2),177B) 
C 
C     PREVIOUS SCREEN REQUESTED ? 
C 
140   IF( PSFLG )  GOTO 350 
C-----NO PREVIOUS SCREEN, LAST SCREEN OF A UPT ?
      IF(IAND(NCRTH(IPTR+1),100000B).NE.0) GOTO 150 
C 
C     SET UP FOR NEXT SCREEN, ADVANCE POINTER ON THE CHAIN
C     TO SET OFSET AND POINTER FOR NEXT TIME
C 
145   IOFST=(2*NCRTH(IPTR))-2 
147   IPTR=(IOFST+2)/2
148   IEXFL=FSCRN(I)
149   CONTINUE
C#################################################################### 
D     KKK=NCRTH(4)
D     KKL=NCRTH+1 
D     KKM=2H1S
D     IF(FSCRN(I)) KKM=2HEX 
D     WRITE(6,8987)KKL,ILAST,KKM,KKK,IPTR 
D8987 FORMAT(2/,"  TMPRS PRINT-OUT: NCRTH+1 ="I5", ILAST ="I5 
D    .", IT IS A "A2"T SCREEN,",/,19X,
D    ."ARRAY FROM",I5"(10) TO"I5"(10) IS:") 
D     DO 8984 KKL=KKK,IPTR,62 
D     KKM=IAND(NCRTH(KKL+2),177B) 
D     KKN=2HLS
D     IF(IAND(NCRTH(KKL+1),100000B).EQ.0) KKN=2HEX
D     WRITE(6,8988)KKN,KKM,KKL,(NCRTH(I),I=KKL,KKL+61)
D8988 FORMAT(X,A2"T OF UPT #"I3,3X, 
D    ." ADDR ="I5,": VAL ="I5,2@10,/" ["30A2,/" ",29A2"]")
D8984 CONTINUE
C#####################################################################
      RETURN
C 
C     IT IS THE LAST SCREEN OF A UPT, SCREEN FULL ? 
C 
150   IF(IGET2(IBUFR,102).EQ.2H  ) GO TO 151
      NUERO=45
      I=20
      GO TO 400 
151   IF(IGET2(IBUFR,119).EQ.2H  ) GO TO 152
      I=23
      NUERO=46
      GO TO 400 
C-----IT IS THE LAST SCREEN OF A UPT, END OF CHAIN ?
152   IF(NCRTH(IPTR).NE.NCRTH+1) GOTO 145 
C 
C     IT IS THE END OF THE CHAIN, START A NEW PROGRAM IF ENOUGH ROOM
C 
165   IF(ITOSC .LT. 26)  GOTO 190 
167   NUERO=17
      GOTO 398
C 
C     THIS SCREEN IS FULL, TRY TO DO AN EXTENSION 
C 
170   IF(ITOSC .GE. 25)  GOTO 167 
C-----SET UP THE EXTENSION SCREEN 
      IF(IPTR.NE.ILAST) GOTO 183
C-----THE EXTENSION IS ON THE LAST UPT
      ILAST=NCRTH+1 
      NCRTH(NCRTH+1)=NCRTH+1+INTMS
      GOTO 184
C-----THE EXTENSION IS IN THE MIDDLE, SET UP TWO LINK 
183   NCRTH(ILAST)=NCRTH(ILAST)+INTMS 
      NCRTH(NCRTH+1)=NCRTH(IPTR)
184   NCRTH(IPTR)=NCRTH+1 
      NCRTH(IPTR+1)=IAND(NCRTH(IPTR+1),77777B)
      IF(IAND(NCRTH(IPTR+1),77600B).EQ.0) NCRTH(IPTR+1)=
     .NCRTH(IPTR+1)+256 
      NCRTH(NCRTH+2)=IOR(NCRTH(IPTR+1)+256,100000B) 
      NCRTH(NCRTH+3)=NCRTH(IPTR+2)
      GOTO 195
C 
C     SET UP FOR A NEW U.P.T. 
C 
190   ILAST=NCRTH+1 
      NCRTH(NCRTH+1)=NCRTH+1+INTMS
      NCRTH(NCRTH+2)=100000B
      NCRTH(NCRTH+3)=IAND(NCRTH(IPTR+2),177B)+1 
195   CALL BLAN(NCRTH,2*(NCRTH+1)+5,ILPRG)
      NCRTH=NCRTH+INTMS 
      ITOSC=ITOSC+1 
C 
C---  CHECKING ITOSC FOR > 25 WAS PUT IN AT PCO 2026 SO THAT
C     T.U.S. 23 WOULD NOT APPEAR AT ALL. IT WOULD HAVE PREVIOUSLY 
C     APPEARED BUT ISSUES AN ERROR IF AN ATTEMPT TO FILL IT 
C     WAS TRIED. BY SETTING IEND TO 1 IT THINKS IT SHOULD BE
C     DONE WITH ALL THE T.U.S. SCREENS. (TRICKED IT)
C 
      IF(ITOSC.GT.25) IEND=1
C 
      GOTO 145
C 
C     SPECIAL CASE: END OF BUFFER, INSERT, PREVIOUS OR ABORT ?
C 
198   IF(IFLG(I) .EQ. 6)  GOTO 80 
C-----SPECIAL CHARACTER, CHECK IT 
200   IF(IFLG(I).NE.9) GOTO 205 
      IF(.NOT.OKABT(LU)) RETURN 
C-----OPERATOR ASK TO ABORT, DO THE ABORT RETURN !
      IEND=2
      RETURN
C 
C     INSERT OR PREVIOUS ?
C 
205   IF(IFLG(I).EQ.8) GOTO 300 
C-----INSERT FUNCTION ? 
      NUERO=34
      IF(IFLG(I).NE.4)  GOTO 400
      IF(I .GE. 21)  GOTO 400 
      IF(.NOT. INSFLG) INSFLD=I 
      INSFLG=.TRUE. 
      GOTO 310
C 
300   IF(.NOT. PSFLG) IFILD=I 
      PSFLG=.TRUE.
310   IF(I.GT.23) GOTO 325
      CALL MOVCA(NCRTH,IOFST+K,IBUFR,K,J) 
      GOTO 28 
325   IF(I.NE.24) GOTO 330
      IBUFR(2)=NCRTH(IPTR+1)
      GOTO 40 
330   IBUFR(3)=NCRTH(IPTR+2)
      IF(I.EQ.25)  GOTO 50
      GOTO 80 
C 
C     EXECUTE THE PREVIOUS SCREEN FUNCTION
C 
350   IF(NBSCR .EQ. IFSCR)  GOTO 360
      NBSCR=NBSCR-1 
      CALL MOVEW(IBUFR(4),NCRTH(IPTR+3),INTMS-3)
      IOFST=IPRVS(NBSCR)
      GOTO 147
360   IEND=3
      RETURN
C 
C     EXECUTE THE INSERT A T.U.S. FUNCTION
C 
380   CALL CTRAC(IBUFR,INSFLD)
      I=INSFLD
      NUERO=34
      IF(IGET2(IBUFR,102).NE.2H  ) GOTO 400 
      IF(INSFLD.EQ.20) GOTO 400 
      KK=97 
      DO 385  IJ=INSFLD,19
      CALL MOVCA(IBUFR,KK,ITEMP,1,5)
      CALL MOVCA(ITEMP,1,IBUFR,KK+5,5)
      CALL BLAN(IBUFR,KK,5) 
385   KK=KK-5 
      CALL MOVEW(IBUFR(4),NCRTH(IPTR+3),INTMS-3)
      RETURN
C 
C     ERROR PROCESSING
C 
398   I=1 
400   IFILD=I 
      IEND=NUERO
      TMPRS=.TRUE.
      GOTO 148
      END 
      LOGICAL FUNCTION DUPNA(NCRPT,IPTRT),92080-1X404 REV.2026  790307
C 
C     FUNCTION TO FIND DUPLICATE TMS-SUBROUTINE NAME
C 
C     FUNCTION IS  TRUE  IF ALL THE 20 TMS-SUBROUTINE NAME
C     (STARTING AT ADDR=NCRPT) ARE ALL UNIQUE.
C     FUNCTION IS  FALSE  IF THERE IS DUPLICATE NAME
C     (III IS THE ADDR OF THE DUPLICATE ONE, THE SECOND ONE)
C 
C 
C     THIS SUBROUTINE WORKS ON THE UNPACKED FORMAT OF NCRTH 
C                                 ----------
C 
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO 
     .             ,NCRTH(1)
C 
      LOGICAL CMPB
C 
      DUPNA=.TRUE.
      IPTRT=1 
      DO 40 K=(2*(NCRPT+3))-1,(2*(NCRPT+3))-1+95,5
      I=NCRTH(4)
10    DO 20 J=(2*(I+3))-1,(2*(I+3))-1+95,5
      IF(IGET2(NCRTH,K).EQ.2H  ) GOTO 35
      IF(IGET2(NCRTH,J).EQ.2H  ) GOTO 20
      IF(J.EQ.K) GOTO 35
      IF(CMPB(NCRTH,J,NCRTH,K,5)) GOTO 50 
20    CONTINUE
30    I=NCRTH(I)
      IF(I.EQ.NCRPT+INTMS) GOTO 35
      GOTO 10 
35    IPTRT=IPTRT+1 
40    CONTINUE
      GOTO 60 
50    DUPNA=.FALSE. 
60    RETURN
      END 
      SUBROUTINE CTRAC(IBUFR,IPT),92080-1X404 REV.2026  790307
C 
C 
C     THIS SUBROUTINE CONTRACTS THE TMS-SUBROUTINES 
C     INSIDE A SCREEN (ELIMINATING EMPTY FIELDS). 
C 
C     THE FIELD NUMBER IN IPT IS UPDATED TO REFLECT THE CHANGE. 
C 
C 
      DIMENSION IBUFR(62) 
C 
      J=7 
      IFILD=1 
      DO 200 II=1,19
      IF(IGET2(IBUFR,J).NE.2H  ) GOTO 100 
      CALL MOVCA(IBUFR,J+5,IBUFR,J,95-(J-7))
      IF(IFILD.LT.IPT) IPT=IPT-1
      CALL BLAN(IBUFR,102,5)
      J=J-5 
100   J=J+5 
      IFILD=IFILD+1 
200   CONTINUE
      J=107 
      DO 400 II=1,2 
      IF(IGET2(IBUFR,J).NE.2H  ) GOTO 300 
      CALL MOVCA(IBUFR,J+6,IBUFR,J,12-(J-107))
      CALL BLAN(IBUFR,119,6)
      J=J-6 
300   J=J+6 
400   CONTINUE
      RETURN
      END 
C 
C 
      SUBROUTINE ORDLU(NCRTH,IOFST,ISZSC),92080-1X404 REV.2026  790613
C 
C 
      DIMENSION NCRTH(1)
      K=(IOFST+2)/2 
      L=(ISZSC/2)-4 
      DO 450 M=K,K+L,4
      IF(NCRTH(M).EQ.NCRTH(M+1))NCRTH(M+1)=0
      IF(NCRTH(M+2).EQ.10000)NCRTH(M+2)=0 
      NCRTH(M+3)=0
450   CONTINUE
      RETURN
      END 
END$