FTN4
      PROGRAM TMPG5(5),92903-16457 REV.1913  790130 
C 
C 
C     NAME:   TMPG5,ILPRS 
C     SOURCE: &TMPG5    92903-18457 
C     BINARY: %TMPG5    92903-16457 
C 
C     PGMR: DANIEL POT/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     *                                                            *
C     *   THIS PROGRAM HANDLES SCREENS # X & Y USING AN INTERC-    *
C     *   TIVE DIALOGUE ON A 2645/2648 TERMINAL.                   *
C     *   DEFINTION OF INTERACTIVE LU (HP 307X TERMINALS)          *
C     *                AND T.U.S. (USER WRITTEN SUBROUTINE)        *
C     *                                                            *
C     **************************************************************
C 
C     STOP USED:  5000 - 5002 - 5003
C     ----------
C 
C     IJOB = 2   SCREEN HAS BEEN PRINT, READ AND ANALYSE
C     IJOB = 3   DO ALL T.U.S. DEFINITION INTO USER PARTITION 
C     IJOB = 0   DO EVERYTHING (LU INT. & AUX. AND T.U.S.) DEFINITION 
C 
C     IEND = 0 : CURRENT INTERACTIVE PROCESS SHOULD BE CONTINUED
C     IEND = 1 : END OF INTERACTIVE PROCESS 
C     IEND = 2 : ABORT TMPGN PROGRAM
C     IEND = 3 : PREVIOUS FAMILY SCREEN 
C 
C 
C-----LABEL COMMON # 1  GENERAL INFORMATION 
C 
      COMMON /TMGC1/LU,LUPRT,LUOUT,ISYTP,ISCRN,IOFST,IEND,IJOB
C 
C-----LABEL COMMON # 2  FLAGS 
C 
      COMMON /TMGC2/IDUM0(31),IMOTR 
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IDUM1(7),NCRTH(2100),IEXFL,IPTR 
C 
C-----LABEL COMMON # 4  I/O BUFFER (MAX SIZE = 100 WORDS) 
C 
      COMMON /TMGC4/IOBUF 
C 
C 
      LOGICAL GETBK,TMPRS 
      LOGICAL IEXFL 
C 
C     CURRENT JOB ON PROCESS
C 
      IF(IJOB.EQ.2) GOTO 90 
      IF(IJOB.EQ.3) GOTO 40 
      IF(IJOB.NE.0) STOP 5000 
C 
C     INTERACTIVE LOGICAL UNIT  (HP 3070 DEVICE)
C 
10    ISCRN=1 
      CALL ILPRS(IOFST,IEND)
      IF(IEND.EQ.3)  GOTO 65
      IF(IEND.NE.1) GOTO 60 
      IOFST=0 
C 
      IF(IMOTR .NE. 1)  GOTO 75 
C 
C     TMS-SUBROUTINES AND LIBRARIES  (USER WRITTEN MODULES) 
C 
40    ISCRN=3 
      IF( TMPRS(IOFST,LENGH,4,IEND,IFLD) )  GOTO 85 
      IF(IEND.EQ.1) GOTO 100
      IF(IEND.NE.3) GOTO 60 
C-----PREVIOUS SCREEN OK ?
      IF(IMOTR .NE. 1)  GOTO 65 
      IOFST=0 
      GOTO 10 
C 
C     RETURN FROM ILPRS, TMPRS
C 
60    IF(IEND.EQ.0) GOTO 70 
      IF(IEND.EQ.2.OR.IEND.EQ.1) GOTO 80
      STOP 5002 
C 
C     PREVIOUS SCREEN NEED TO ACTUALLY CHANGE THE SCREEN, 
C     IF NOT ALLOWED, RE-ISSUE THE SAME ONE AND PRINT ERROR ! 
C 
65    IEND=-33
C 
C     INTERACTIVE PROCESS, PRINT THE SCREEN.
C 
70    CALL TMGSC(3,ISCRN,IOFST,IEND,2)
C 
C     END OF INTERACTIVE PROCESS, ABORT OR PARTIAL PROCESS
C 
75    IEND=1
80    CALL TMGSC(0,0,0,IEND,IJOB) 
C 
C     ERROR PROCESSING: 
C 
84    IEND=-IEND
      IFLD=1
85    CALL TMPGE(IEND,IFLD) 
C 
C     SET UP INPUT LENGTH 
C 
90    LENGH=0 
      IF(IEND .LT. 0)  GOTO 84
      IF(ISCRN.EQ.1) LENGH=63 
      IF(ISCRN.EQ.3) LENGH=140
      IF(LENGH.EQ.0) STOP 5003
C 
C     WAIT FOR INPUT FROM THE 2645
C 
95    IF(GETBK(LU,IOBUF,LENGH)) GOTO 70 
C 
C     DISPATCH TO ANALYSIS CODE 
C 
      IF(ISCRN .EQ. 1)  GOTO 10 
      IF(ISCRN .EQ. 3)  GOTO 40 
C 
C     INTERACTIVE PROCESS: CONTINUED WITH IMAGE & MAIN DEFINITION 
C 
100   IF(IMOTR .NE. 1)  GOTO 75 
      ISCRN=0 
      IOFST=0 
      IJOB=0
      CALL TMGSC(4,ISCRN,IOFST,IEND,IJOB) 
C 
C     DUMMY CALL TO MAIN  !!
C 
      CALL TMPGN
      END 
      SUBROUTINE ILPRS(IOFST,IEND),92903-16457 REV.1913  790130 
C 
C 
C     *************************************************** 
C     *                                                 * 
C     * THIS SUBROUTINE PROCESS SCREEN NUMBER 1 CONTENT * 
C     * BEFORE TRANLATING IT IN TABLE "NCRTH".          * 
C     *                                                 * 
C     * IF IOFST=0 : INITIALISATION TAKE PLACE          * 
C     *                                                 * 
C     * IF IOFST#0 : PENDING SCREEN IS PROCESSED AND A  * 
C     * MESSAGE CAN BE SENT TO POINT AT AN ERROR.       * 
C     *                                                 * 
C     * WHEN A SCREEN IS RECEIVED, UNCOMPLETELY FILLED, * 
C     * AND IS GOOD, IT IS CONSIDERED AS THE LAST ONE   * 
C     * OF THE SCREEN NUMBER ONE FAMILY AND NCRTH(2000) * 
C     * IS DECONTRACTED IN THE STANDARD FORMAT INTO THE * 
C     * NCRTH(45) INITIAL TABLE AND IEND IS SET TO "1". * 
C     * IF ABORT KEY WAS DEPRESSED IEND IS SET TO "2".  * 
C     * IF PREVIOUS SCREEN KEY WAS USED, TO GO BACK     * 
C     * BEFORE THIS SCREEN, IEND IS SET TO "3"          * 
C     *                                                 * 
C     *************************************************** 
C 
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(1)
C 
C-----LABEL COMMON # 4  I/O BUFFER ( MAX SIZE = 100 WORDS  )
C 
      COMMON /TMGC4/IOBUF 
C 
      DIMENSION NAME(3),IBUFR(192),IPOB(3)
      LOGICAL JPAR,ISBTW,OKABT,GETBK
C 
C 
      ISZSC=48
      ILONG=64
      IF(IOFST.NE.0) GOTO 30
C 
C     FIRST TIME ILPRS IS CALLED
C 
      IEND=0
      CALL CTILU
      IOFST=IDECL 
      RETURN
C 
C     INTERACTIVE LU# PHASE IS PROCESSING 
C 
30    IEND=0
      CALL NUL(IBUFR,24)
      IFIN=0
      IPRVS=0 
C 
C     ACQUISITION 
C 
      DO 90 I=1,(ISZSC/2)-2,3 
      J=I 
      IF(JPAR(IOBUF,ILONG,I,IPOB,2,IFLG,IBUFR(I))) GOTO 200 
      IFLG1=IFLG
      IBUFR(I+1)=0
      IF(JPAR(IOBUF,ILONG,I+1,IPOB,2,IFLG,IBUFR(I+1))) GOTO 200 
      IFLG2=IFLG
      IBUFR(I+2)=2H 
      IF(JPAR(IOBUF,ILONG,I+2,IBUFR(I+2),1,IFLG,IPOB)) GOTO 200 
      IFLG3=IFLG
      IF(IFLG1+IFLG2+IFLG3.NE.0) GOTO 35
C 
C     CHECK FOR PREVIOUS SCREEN OR ABORT COMMAND
C 
      IBUFR(I)=0
      IBUFR(I+1)=0
      IBUFR(I+2)=2H 
      IF(J.NE.(ISZSC/2)-2) J=J+3
      DO 33 II=J,(ISZSC/2)-2,3
      IF(JPAR(IOBUF,ILONG,II,IPOB,2,IFLG,IBUFR(II))) GOTO 34
      IF(JPAR(IOBUF,ILONG,II+1,IPOB,2,IFLG,IBUFR(II+1))) GOTO 34
      IBUFR(II+2)=2H
      IF(JPAR(IOBUF,ILONG,II+2,IBUFR(II+2),1,IFLG,IPOB)) GOTO 34
33    CONTINUE
      IF(I.NE.1.OR.IOFST.NE.IDECL) GOTO 3033
      J=1 
      CALL TMPGE(43,J)
      GOTO 110
3033  IFIN=1
      CALL NUL(IBUFR(J),24-J) 
      CALL MOVEW(IBUFR,NCRTH((IOFST+2)/2),ISZSC/2)
      IOFST=IOFST+ISZSC 
      GOTO 92 
C 
C     ABORT OR PREVIOUS SCREEN ( WITH INPUT ) 
C 
34    IPRVS=0 
      IF(IFLG.NE.8) GOTO 330
      CALL NUL(IBUFR(J),24-J) 
      IPRVS=1 
      GOTO 92 
C 
C     CHECK DEFINED LU, 1<LU#<LUMAX, LU1<LU2, DEFINED TYPE
C 
35    IF(IFLG1.EQ.0) GOTO 60
      IF(IFLG1.NE.1) GOTO 70
      LUMAX=IGET(1653B) 
      CALL CNUMD(LUMAX,IPOB)
      IF(ISBTW(IBUFR(I),1,LUMAX)) GOTO 75 
      J=I+1 
      IF(IFLG2.EQ.0) IBUFR(I+1)=0 
      IF(IFLG2.NE.1.AND.IFLG2.NE.0) GOTO 70 
      IF(IBUFR(I+1).LT.IBUFR(I).AND.IBUFR(I+1).NE.0) GOTO 85
      IF(ISBTW(IBUFR(I+1),0,LUMAX)) GOTO 75 
C 
C     CHECK THAT LU# IS USING DVR47 
C 
42    DO 55 ILOP=IBUFR(I),IBUFR(I+1)
      IEQT=IAND(IGET(IGET(1652B)+ILOP-1),77B) 
      IDVTYP=IAND(IGET(IGET(1650B)+((IEQT-1)*15)+4),37400B)/256 
      IF(IDVTYP.EQ.47B .OR. IDVTYP.EQ.07B)  GOTO 55 
      CALL CNUMD(ILOP,IPOB) 
46    CALL TMPGE(12,J-1,IPOB(3))
      GOTO 110
55    CONTINUE
C 
C     CHECK LU# IS NOT 1,2,3,CRT# 
C 
      IF(IBUFR(I+1).EQ.0) IBUFR(I+1)=IBUFR(I) 
      ICHLU=1 
      DO 50 ILOP=1,4
      IF(ISBTW(ICHLU,IBUFR(I),IBUFR(I+1))) GOTO 40
      CALL CNUMD(ICHLU,IPOB)
      GOTO 46 
40    IF(ILOP.EQ.1.OR.ILOP.EQ.2) ICHLU=ICHLU+1
      IF(ILOP.EQ.3) ICHLU=LU
50    CONTINUE
C 
C     IS THERE A DELETE OPERATION TO PERFORM ?
C 
      J=I+2 
      IF(IFLG3.NE.3.AND.IFLG3.NE.0) GOTO 80 
      IF(IFLG3.EQ.3.AND.IBUFR(I+2).EQ.2HX ) IBUFR(I+2)=-1 
      IF(IFLG3.EQ.0) IBUFR(I+2)=3070
      IF(IBUFR(I+2).NE.-1.AND.IBUFR(I+2).NE.3070) GOTO 80 
      IF(IBUFR(3).EQ.-1 .AND. IOFST.EQ.IDECL)  GOTO 65
90    CONTINUE
      GOTO 91 
C 
C     TMPGE MESSAGES
C 
60    CALL TMPGE(10,J)
      GOTO 110
65    CALL TMPGE(11,1)
      GOTO 110
70    CALL TMPGE(3,J) 
      GOTO 110
75    CALL TMPGE(44,J,IPOB(3))
      GOTO 110
80    CALL TMPGE(19,J)
      GOTO 110
85    CALL TMPGE(41,J)
      GOTO 110
C 
91    CALL MOVEW(IBUFR,NCRTH((IOFST+2)/2),ISZSC/2)
      IOFST=IOFST+ISZSC 
C 
C     CHEK FOR DUPLICATE LU#
C 
92    CALL DUPLU(NCRTH(2000),((IOFST-IDECL)/2),IFILD,LUER)
      IF(LUER.EQ.0) GOTO 100
      IF(LUER.EQ.-1) GOTO 95
      CALL TMPGE(8,IFILD,LUER)
93    IOFST=IOFST-ISZSC 
      GOTO 110
95    CALL TMPGE(11,IFILD)
      GOTO 93 
C 
C     NEXT OR PREVIOUS SCREEN 
C 
100   IF(IFIN.EQ.1) GOTO 340
      IF(IPRVS.EQ.1) GOTO 300 
      RETURN
C 
C     ******************************************************
C 
C 
C     WAITING FOR OPERATOR INPUT
C 
110   IF(.NOT.GETBK(LU,IOBUF,63)) GOTO 30 
      RETURN
C 
C     SPECIAL FUNCTION KEYS PROCESS 
C     ------------------------------
C 
C     ABORT OR PREVIOUS SCREEN ( WITHOUT INPUT )
C 
200   IF(IFLG.NE.9) GOTO 210
      IF(.NOT.OKABT(LU)) RETURN 
C-----OPERATOR WANTS TO ABORT, DO IT
205   IEND=2
      RETURN
C 
210   IF(IFLG.EQ.8.AND.IOFST.EQ.IDECL) GOTO 320 
      IF(IFLG.EQ.8.AND.IOFST.NE.IDECL) IOFST=IOFST-ISZSC
      IF(IFLG.EQ.8) RETURN
      GOTO 320
C 
C     PREVIOUS SCREEN ( WITH INPUT )
C 
300   CALL NUL(NCRTH(IREFC),ILUGH)
      CALL MOVEW(IBUFR,NCRTH((IOFST+2)/2),ISZSC/2)
      IF(IOFST.EQ.IDECL) GOTO 320 
      IOFST=IOFST-ISZSC 
      RETURN
C 
C     PREVIOUS SCREEN NEED AN OTHER SCREEN, BEFORE LU DEFINITION
C 
320   IEND=3
      RETURN
C 
C     ABORT COMMAND 
C 
330   IF(IFLG.NE.9) GOTO 335
      IF( OKABT(LU) )  GOTO 205 
C 
C     REJECT ILLEGAL CHARACTER. 
C 
335   CALL TMPGE(34,J)
      GOTO 110
C 
C     END OF INTERACTIVE LU PROCESS 
C 
340   CALL NUL(NCRTH(IREFC),ILUGH)
      CALL NUL(NCRTH((IOFST+2)/2),3)
      CALL DPILU
      IF(NCRTH(IREFC) .NE. 0)  GOTO 350 
      CALL TMPGE(43,1)
      GOTO 93 
350   IEND=1
      RETURN
      END 
      END$