FTN4
      PROGRAM TMPG4(5),92903-16456 REV.1913  790122 
C 
C 
C     NAME:   TMPG4 
C     SOURCE: &TMPG4    92903-18456 
C     RELOC:  %TMPG4    92903-16456 
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     *                                                            *
C     *   THIS PROGRAM HANDLES SCREEN # 4 USING AN INTERACTIVE     *
C     *   DIALOGUE ON A 2645/2648 TERMINAL.                        *
C     *   DEFINITION OF THE IMAGE DATA-BASE                        *
C     *                                                            *
C     **************************************************************
C 
C     STOP USED:  4000 - 4010 
C     ----------
C 
C 
C     IJOB = 2   THE SCREEN HAS BEEN PRINT, READ AND ANALYSE ANSWER 
C     IJOB = 0   DO IMAGE & MAIN PROG DEFINITION
C 
C     IEND = 0 : CURRENT INTERACTIVE PROCESS
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/ITMFL,IRQFLG(30),IMOTR(9) 
C 
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO 
     .             ,NCRTH(1)
C 
C 
C-----LABEL COMMON # 4  I/O BUFFER (MAX SIZE = 100 WORDS) 
C 
      COMMON /TMGC4/IOBUF 
C 
      DIMENSION NAME(3),IPOB(3),IBUFR(30) 
      DIMENSION KBUFR(44),LNFLD(5)
C 
      LOGICAL JPAR,KPAR,CMPW,PSFLG,GETBK,OKABT,STUSP
      LOGICAL IMBED,ISBTW,CMPW
      INTEGER OPEN,PURGE
C 
      DATA LNFLD/5,6,5/,IBFSZ/15/ 
D     DATA LUOXXX/40/ 
C 
      KPAR(IX1,IX2,IX3)=JPAR(IOBUF,LENGH,I,IX1,IX2,IFLG,IX3)
C 
C 
C     JOB ? 
C 
      ISZSC=20
      IF(IJOB.EQ.2) GOTO 220
      IF(IJOB.NE.0) STOP 4000 
C 
C     ***************************************************************** 
C     *                                                               * 
C     *   DATA-BASE DEFINITION:                                       * 
C     *                                                               * 
C     ***************************************************************** 
C 
C     DISPLAY SCREEN # 4
C 
5     ISCRN=4 
      IF(IOFST .EQ. 0)  IOFST=IDECL-ISZSC 
10    IOFST=IOFST+ISZSC 
      K=1+(IOFST-IDECL)/ISZSC 
      J=27+IBFSZ*(K-1)
      IF(NCRTH(J) .NE. 0)  GOTO 12
C-----NO DATA-BASE DEFINED YET, INIT THE BUFFER 
      CALL MOVEW(12H            ,NCRTH(J),6)
      NCRTH(J+6)=0
12    CALL MOVCA(K,1,NCRTH,IOFST+1,2) 
      CALL MOVCA(NCRTH(J),1,NCRTH,IOFST+3,5)
      CALL MOVCA(NCRTH(J+3),1,NCRTH,IOFST+8,6)
      CALL MOVCA(NCRTH(J+6),1,NCRTH,IOFST+14,2) 
D     I1=IDECL/2+1
D     WRITE(LUOXXX,9877)K,J,IOFST,(NCRTH(I),I=I1,I1+79) 
D9877 FORMAT(/"   K="I2,",    J="I3",   IOFST="I6",   NCRTH:" 
D    .,10(/8@8))
      GOTO 210
C 
C     PROCESS SCREEN # 4
C 
20    PSFLG=.FALSE. 
      K=1+(IOFST-IDECL)/ISZSC 
      J=27+IBFSZ*(K-1)
      L=J 
      I=1 
C 
C     DATA BASE NAME & LEVEL ACCESS WORD ANALYSIS 
C 
25    IF( KPAR(IBUFR,LNFLD(I),IPOB) )  GOTO 360 
      NUERO=18
      IF( .NOT. (IFLG.EQ.0.OR.IFLG.EQ.3) )  GOTO 400
      IF(IMBED(IBUFR,1,LNFLD(I)))  GOTO 400 
      CALL ISUPB(IBUFR,3) 
      NUERO=39
      IF(NCRTH(J).EQ.2H  .AND.I.NE.1.AND.IFLG.NE.0)  GOTO 400 
      CALL MOVEW(IBUFR,NCRTH(L),3)
30    I=I+1 
      L=L+3 
      IF(I .LT. 3)  GOTO 25 
C 
C     DATA BASE SECURITY CODE 
C 
      IBUFR=0 
      IF( KPAR(IPOB,5,IBUFR) )  GOTO 360
      NUERO=6 
      IF( .NOT. (IFLG.EQ.0.OR.IFLG.EQ.1) )  GOTO 400
      NUERO=39
      IF(NCRTH(J).EQ.2H   .AND. IFLG.NE.0)  GOTO 400
      IF(IBUFR .LT. 0)  GOTO 400
      NCRTH(J+6)=IBUFR
40    IF(NCRTH(J) .EQ. 2H  )  GOTO 130
C 
C-----VERIFY THAT THE SAME DATA BASE IS NOT DEFINED TWICE 
C 
      IF(K .EQ. 1)  GOTO 70 
      L=27
      NUERO=40
      I=1 
      DO 53 KK=1,K-1
      IF( CMPW(NCRTH(L),NCRTH(J),3) )  GOTO 400 
53    L=L+15
C 
C     THE DATA BASE IS DEFINED BY NAME,...  OPEN IT 
C     TO VERIFY SECURITY CODE AND HIGHEST LEVEL ACCESS WORD 
C 
70    CALL DBINT(NCRTH(J),NCRTH(J+6),0,IPOB)
      IF(IPOB .NE. 0)  GOTO 78
      CALL MOVEW(NCRTH(J+3),KBUFR,3)
      CALL DBOPN(NCRTH(J),KBUFR,NCRTH(J+6),1,IPOB)
      IF(IPOB .NE. 0)  GOTO 75
      IF(IPOB(2) .NE. 15)  IPOB=10000 
75    CALL DBCLS(0,ISTAT) 
      IF(IPOB .EQ. 0)  GOTO 82
78    IFLD=1
      NUERO=0 
      IF(IPOB .EQ. 128)  NUERO=25 
      IF(IPOB .EQ. 129)  NUERO=26 
      IF(IPOB .EQ. 119)  NUERO=27 
      IF(IPOB .EQ. 116)  NUERO=27 
      IF(IPOB .EQ. 6)    NUERO=27 
      IF(NUERO .NE. 0)   GOTO 410 
      IFLD=2
      IF(IPOB .EQ. 10000) NUERO=28
      IF(NUERO .NE. 0)  GOTO 410
      IFLD=3
      IF(IPOB .EQ. 117)  NUERO=29 
      IF(NUERO .NE. 0)   GOTO 410 
      CALL JASC(IPOB,IBUFR,1,6) 
      CALL TMPGE(30,2,IBUFR(2)) 
      GOTO 220
82    IPOB=ISTAT
      IF(IPOB .NE. 0)  GOTO 78
C 
C-----IMAGE DEFINITION OK, SET THE PROGRAM NAME 
C 
      CALL MOVEW(NCRTH(J),NCRTH(J+9),3) 
C-----SET LOCK TABLE SIZE 
      NCRTH(J+14)=4096
      IF( PSFLG )  GOTO 368 
      GOTO 140
130   CALL NUL(NCRTH(J),IBFSZ)
      IF( PSFLG )  GOTO 368 
      IF(K .EQ. 4)  GOTO 160
      CALL MOVEW(NCRTH(J+IBFSZ),NCRTH(J),IBFSZ*(4-K)) 
      CALL NUL(NCRTH(27+3*IBFSZ),IBFSZ) 
      IOFST=IOFST-ISZSC 
      IF(NCRTH(J) .EQ. 0)  GOTO 160 
140   IF(K .LT. 4)  GOTO 10 
      K=K+1 
C-----END OF INTERACTIVE PROCESS, RETURN TO MONITOR (SEG# 0)
160   NCRTH(26)=K-1 
      CALL TMGSC(0,0,0,1,2) 
C 
C 
C     PRINT SCREEN
C 
210   CALL TMGSC(3,ISCRN,IOFST,IEND,2)
C 
C     READ FROM THE 2645 TERMINAL 
C 
220   LENGH=0 
      IF(IEND .LT. 0)  GOTO 420 
      IF(ISCRN.EQ.4) LENGH=18 
      IF(LENGH.EQ.0)  STOP 4010 
C 
      IF(.NOT.GETBK(LU,IOBUF,LENGH)) GOTO 350 
C 
C     RE-DISPATCH AFTER AN HARD ERROR, RE-ISSUE THE SCREEN
C 
310   IF(ISCRN.EQ.4) GOTO 10
      STOP 4012 
C 
C     DISPATCH TO SCREEN ANALYSIS PART
C 
350   IF(ISCRN.EQ.4) GOTO 20
C 
C     ABORT OR PREVIOUS SCREEN COMMAND
C 
360   IF(IFLG .EQ. 8)  GOTO 365 
      NUERO=34
      IF(IFLG .NE. 9)  GOTO 400 
C-----USER WANTS TO ABORT ? 
      IF( .NOT. OKABT(LU))  GOTO 310
C-----YES, OPERATOR WANTS TO ABORT
      CALL TMGSC(0,0,0,2) 
C-----EXECUTE THE PREVIOUS SCREEN COMMAND 
365   IF(.NOT. PSFLG)  IPS=IFLD 
      PSFLG=.TRUE.
      IF(ISCRN.EQ.4) GOTO (30,30,40),I
C 
368   IF(ISCRN.NE.4)  STOP 4015 
      IF(IOFST .LE. IDECL)  GOTO 370
      IOFST=IOFST-2*ISZSC 
      GOTO 10 
370   IF(IMOTR.NE.1) GOTO 380 
C-----GO TO PREVIOUS SCREEN (SCREEN#3, DEFINITION OF TUS) 
      CALL TMGSC(5,0,0,0,3) 
C 
380   IEND=-33
      IOFST=0 
      GOTO 5
C 
C     ERROR MESSAGE 
C 
400   IFLD=I
410   IF( PSFLG )  GOTO 365 
      GOTO 440
420   IFLD=1
      NUERO=-IEND 
      IEND=0
440   CALL TMPGE(NUERO,IFLD)
      GOTO 220
C 
C     DUMMY CALL TO MAIN  !!
C 
7777  CALL TMPGN
      END 
      END$
                                                                            