FTN4
      PROGRAM TGPI1(5), 92903-16375 REV.1913  790209 0945 
C 
C     SOURCE 92903-18375
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 
C 
C      PRGMR : JEAN CHARLES MIARD (HPG) 
C 
C 
C***********************************************************************
C*                                                                     *
C*                         THIS IS A SEGMENT OF THE TGP PROGRAM USED   *
C*      TO INTERFACE TGP WITH THE IMAGE DATA BASE . DIFFERENT TASKS    *
C*      ARE PERFORMED BY TGP11 ACCORDING TO INDIC VALUE :              *
C*                                                                     *
C*    IF :  INDIC = -1 :  REQUEST FROM TGP1 TO CLOSE THE DATA BASE .   *
C*                        THEN TGP IS FINISHED .                       *
C*          INDIC = -2 :  REQUEST FROM TGP14 TO PRINT THE LISTING OF   *
C*                        THE IMAGE OPERATIONS DEFINED FOR THE CURRENT *
C*                        TRANSACTION SPEC.                            *
C*          INDIC = -3 :  REQUEST FROM TGP7 TO PROCESS THE IMAGE ADD   *
C*                        STORAGE OF THE STORAGE STATE .               *
C*          INDIC =  0 :  REQUEST FROM TGP1 TO OPEN THE DATA BASE      *
C*                        DECLARED BY THE USER IN SCREEN 4 .           *
C*                                                                     *
C*                                                                     *
C***********************************************************************
C 
C 
C  DECLARATIONS COMMON VARIABLES ***********
C 
      COMMON ILU,ISCRN,IQST,ISKIP,INDIC 
      COMMON IFORM(766) 
      COMMON JFORM(1400)
      COMMON MFORM(16)
      COMMON LFORM(39)
      COMMON ITT
      COMMON IKEY(26,3) 
      COMMON IUMAX,IMMAX
      COMMON IMODB
      COMMON ILITE(15)
      COMMON IMAI(45,5) 
      COMMON IMFLG,IMAS,IMDT,IMKY 
      COMMON KFORM(2704)
      COMMON ILIBR(61)
      COMMON NIMAG
C 
C************ LOCAL ARRAYS************* 
C 
      DIMENSION ILIST(46),ILEVL(3),INAM(3),IER(3),ISTAT(2)
      DIMENSION JIM(13),JSTAR(13),JDEL(15),JUP(3),JAD(3),JITM(4)
      DIMENSION IMSTA(6),IBUF(12),JNAM(3),KBUF(5),IER1(3) 
      DIMENSION LNAM(3),KNAM(3),JOP(17) 
C 
      LOGICAL ISBIT,INUM
C 
C *********** DATA ASSIGNEMENTS ***************** 
C 
      DATA ILIST/2H  ,2HTG,2HP ,2H  ,2HTG,2HP0,2H  ,2HTG,2HP1,2H
     C,2HTG,2HP2,2H  ,2HTG,2HP3,2H  ,2HTG,2HP4,2H  ,2HTG,2HP5,2H
     C,2HTG,2HP6,2H  ,2HTG,2HP7,2H  ,2HTG,2HP8,2H  ,2HTG,2HP9,2H
     C,2HTG,2HP1,2H0 ,2HTG,2HP1,2H1 ,2HTG,2HP1,2H2 ,2HTG,2HP1,2H3 / 
      DATA ILEVL/2H  ,2H  ,2H  /
      DATA INAM/2HTG,2HP1,2H  / 
      DATA JNAM/2HTG,2HP7,2H  / 
      DATA LNAM/2HTG,2HP6,2H  / 
      DATA KNAM/2HTG,2HPI,2H4 / 
      DATA JIM/2HIM,2HAG,2HE ,2HOP,2HER,2HAT,2HIO,2HNS,2H D,2HEF, 
     C2HIN,2HED,2H :/ 
      DATA JSTAR/2H**,2H**,2H**,2H**,2H**,2H**,2H**,2H**,2H**,2H**, 
     C2H**,2H**,2H**/ 
      DATA JDEL/2H- ,2HDE,2HLE,2HTE,2H E,2HNT,2HRY,2H I,2HN ,2HDA,
     C2HTA,2H S,2HET,2H :,2H  / 
      DATA JUP/2HUP,2HDA,2HTE/
      DATA JAD/2H A,2HDD,2H  /
      DATA JITM/2H I,2HTE,2HMS,2H :/
      DATA JOP/2H  ,2H* ,2HER,2HRO,2HR ,2HIN,2H O,2HPE,2HNI,2HNG,2H T,
     C2HHE,2H D,2HAT,2HA ,2HBA,2HSE/
C 
C*********************************************************************
C 
C             GO TO PERFORM THE REQUIRED PROCESSING 
C 
C*********************************************************************
C 
      IF(INDIC.EQ.-1) GO TO 900 
      IF(INDIC.EQ.-2) GO TO 6000
      IF(INDIC.EQ.-3) GO TO 500 
C 
C*********************************************************************
C 
C  INDIC = 0 :  REQUEST TO OPEN THE DATA BASE 
C 
C*********************************************************************
C 
C   ISKIP CONTAINS THE DATA BASE SECURITY CODE
C 
100   ILIST(1)=15 
      CALL DBINT(IFORM(38),ISKIP,ILIST,ISTAT) 
      IF(ISTAT.NE.0) GO TO 3000 
      CALL DBOPN(IFORM(38),ILEVL,ISKIP,1,ISTAT) 
      IF(ISTAT.NE.0) GO TO 3000 
C 
C  THE DATA BASE IS SUCCESSFULY OPENED RETURN TO TGP1 SEGMENT 
C 
      INDIC=2 
135   CALL EXEC(8,INAM) 
C 
C***********************************************************************
C 
C   INDIC = -3  ADD STORAGE PROCESSING
C 
C***********************************************************************
C 
C 
500   INDIC=0 
      N3=ISKIP
      DO 510 I=1,6
510   IMSTA(I)=KFORM(1059+I)
C 
C***********************************************************************
C 
C   ADD IN MASTER DATA SETS 
C 
C***********************************************************************
C 
C   I IS POINTER IN IMSTA 
C   IX IS SECOND WORD OF BUFFER ADD 
C   IY IS # OF ITEMS PER ADD OPERATION
C 
      DO 530 I=1,IMSTA
      CALL DBINF(2HS ,2,IMSTA(I+1),IBUF)
      IF(IBUF.NE.0) GO TO 3000
      IF(IGET1(IBUF,10).NE.1HM) GO TO 530 
C 
C  A BUFFER FOR AN ADD IN A MASTER DATA SET MUST BE CREATED 
C 
C  STORAGE CODE,IMAGE STORAGE CODE,FOT FLAG,AND DATA SET TO ADD 
C 
C 
      KFORM(N3)=52001B
      KFORM(N3)=IOR(KFORM(N3),IMSTA(I+1)*16)
      IX=N3+1 
      N3=N3+2 
C 
C  GET THE KEY ITEM OF THIS MASTER DATA SET 
C  STORED IN IBUF(3)
C  IKFLG IS FLAG SET IF KEY ITEM IS FOUND IN THE FORM 
C 
      CALL DBINF(2HI ,3,IMSTA(I+1),IBUF)
      IF(IBUF.NE.0) GO TO 3000
C 
C  NOW SEARCH ITEMS FOR THIS ADD
C 
      IY=0
      IKFLG=0 
      DO 520 J=1,45 
C 
C  K IS DATA SET TO WHICH ITEM BELONG 
C 
      K=IAND(IMAI(J,3),377B)
      IF((K.NE.IMSTA(I+1)).OR.(IAND(IMAI(J,2),7).NE.2)) GO TO 520 
C 
C  K IS ITEM #
C 
      IY=IY+1 
      K=IAND(IMAI(J,1),377B)
      IF(K.EQ.IBUF(3)) IKFLG=1
      KFORM(N3)=IALF2((IAND(IMAI(J,4),377B)/2)) 
      KFORM(N3)=IOR(KFORM(N3),K)
      N3=N3+1 
      KFORM(N3)=IMAI(J,5) 
      N3=N3+1 
520   CONTINUE
C 
C  IF IKFLG=0 KEY ITEM NOT DEFINED FOR THIS ADD 
C 
      IF(IKFLG.NE.0) GO TO 525
      ITN=IBUF(3) 
      GO TO 2900
525   KFORM(IX)=IY
530   CONTINUE
C 
C*********************************************************************
C 
C  NOW PROCESS ADD IN DETAIL DATA SETS
C 
C*********************************************************************
C 
C 
C   I IS POINTER IN IMSTA 
C   IX POINTS TO SECOND WORD OF BUFFER
C   IY IS # OF ITEMS PER ADD OPERATION
C 
C 
C  FIRST ISOLATE DETAIL SET TO ADD
C 
      DO 800 I=1,IMSTA
      CALL DBINF(2HS ,2,IMSTA(I+1),IBUF)
      IF(IBUF.NE.0) GO TO 3000
      IF(IGET1(IBUF,10).NE.1HD) GO TO 800 
C 
C  A DATA SET IS ISOLATED 
C  FOT IS INITIALIZED TO 1
C 
      FOT=1 
C 
C  INCLUDE STORAGE CODE,IMAGE STORAGE CODE
C  DATA SET # TO ADD
C 
      KFORM(N3)=50001B
      KFORM(N3)=IOR(KFORM(N3),IMSTA(I+1)*16)
      IX=N3+1 
      N3=N3+2 
      IY=0
C 
C   SEARCH KEY ITEMS # OF THIS DATA SET 
C   STORE THEM IN IBUF
C 
      CALL DBINF(2HI ,3,IMSTA(I+1),IBUF)
      IF(IBUF.NE.0) GO TO 3000
C 
C   SEARCH KEY ITEMS IN FORM
C   J IS POINTER IN IBUF
C   ALL KEYS MUST BE DEFINED IN THE FORM BY THEIR NAME IN THE 
C   DATA SET TO ADD OR WITH A LINKED NAME AND THEY MUST BE ASSOCIATED 
C   IN PRIORITY ORDER WITH  - AN ADD OPERATION
C                           - A DISPLAY OPERATION 
C 
      DO 600 J=1,IBUF(2)
      IOP=2 
540   ITN=IBUF(J+2) 
      K=ILIN(IMAI,ITN,IOP)
      IF(K.NE.-1) GO TO 560 
      CALL ITEQU(ITN,KBUF)
      DO 550 L=1,5
      IF(KBUF(L).EQ.0) GO TO 550
      K=ILIN(IMAI,KBUF(L),IOP)
      IF(K.NE.-1) GO TO 560 
550   CONTINUE
      IF(IOP.EQ.2) GO TO 551
      IF(IOP.EQ.5) GO TO 552
      IF(IOP.EQ.0) GO TO 553
      GO TO 2900
551   IOP=5 
      GO TO 540 
552   IOP=0 
      GO TO 540 
C-----DO IT FOR CHECK EXISTENCE.
553   IOP=3 
      GO TO 540 
C 
C   A KEY ITEM FOR ADD IS FOUND ON LINE K OF IMAI 
C 
560   IF((K.GT.2*IUMAX).AND.(K.LT.41)) IFOT=0 
      IY=IY+1 
      KFORM(N3)=IALF2((IAND(IMAI(K,4),377B)/2)) 
      KFORM(N3)=IOR(KFORM(N3),ITN)
      N3=N3+1 
      KFORM(N3)=IMAI(K,5) 
      N3=N3+1 
600   CONTINUE
C 
C   NOW INCLUDE NON KEY ITEMS FOR THIS ADD
C 
      DO 620 J=1,45 
      K=IAND(IMAI(J,3),377B)
      IOP=IAND(IMAI(J,2),7) 
      IF((K.NE.IMSTA(I+1)).OR.(IOP.NE.2)) GO TO 620 
      IF(ISBIT(IMAI(J,2),3)) GO TO 620
      IF((J.GT.2*IUMAX).AND.(J.LT.41)) IFOT=0 
      IY=IY+1 
      KFORM(N3)=IALF2((IAND(IMAI(J,4),377B)/2)) 
      KFORM(N3)=IOR(KFORM(N3),IAND(IMAI(J,1),377B)) 
      N3=N3+1 
      KFORM(N3)=IMAI(J,5) 
      N3=N3+1 
620   CONTINUE
      KFORM(IX)=IY
      KFORM(IX-1)=IOR(KFORM(IX-1),IFOT*2000B) 
800   CONTINUE
C 
C   RETURN TO TGP7
C 
      INDIC=2 
      ISKIP=N3
      CALL EXEC(8,JNAM) 
C 
C************************************************************************ 
C 
C  ERROR PROCESSING 
C 
C***********************************************************************
C 
C  MISSING KEY ITEM FOR ADD 
C 
2900  CALL DBINF(2HI ,2,ITN,IBUF) 
      IF(IBUF.NE.0) GO TO 3000
      CALL MOVEW(IBUF(2),IER,3) 
      CALL DBINF(2HS ,2,IMSTA(I+1),IBUF)
      IF(IBUF.NE.0) GO TO 3000
      CALL MOVEW(IBUF(2),IER1,3)
      CALL MES11(5,1,IER,IER1)
      INDIC=0 
      CALL EXEC(8,LNAM) 
C 
C  ERROR PROCESSING DATA BASE OPEN
C 
3000  IMES=0
      INDIC=0 
      NOF=6 
      IF(ISTAT.EQ.6) IMES=2 
      IF(ISTAT.EQ.129) IMES=3 
      IF(ISTAT.NE.117) GO TO 3010 
      NOF=7 
      IMES=1
C 
C  A SPECIAL MESSAGE EXISTS 
C 
3010  IF(IMES.EQ.0) GO TO 3020
      CALL MES11(IMES,NOF)
      GO TO 135 
C 
C  A GENERAL PRINT MESSAGE FOR IMAGE MUST BE PRINTED
C  IER CONTAINS THE ASCII CODE OF THE ERROR # 
C 
3020  CALL CNUMD(ISTAT,IER) 
      CALL MES11(4,NOF,IER) 
      GO TO 135 
C 
5000  STOP 5000 
C 
C***********************************************************************
C 
C  INDIC = -2  PRINT LISTING OF IMAGE OPERATIONS :
C 
C***********************************************************************
C 
C    IF MODE OF OPERATION IS L OPEN THE DATA BASE 
C 
6000   IF(IGET1(IFORM,13).NE.1HL) GO TO 6005
      IF(INUM(IFORM,81,5,N)) GO TO 5000 
      ILIST(1)=15 
      CALL DBINT(IFORM(38),N,ILIST,ISTAT) 
      IF(ISTAT.NE.0) GO TO 6004 
      CALL DBOPN(IFORM(38),ILEVL,N,1,ISTAT) 
      IF(ISTAT.EQ.0) GO TO 6005 
6004  CALL EXEC(2,ISKIP,JOP,17) 
      GO TO 6100
C 
C   PRINT HEADER
C 
C 
6005  CALL BLANC(ILIST,15)
      CALL EXEC(3,1100B+ISKIP,1)
      CALL MOVEW(JIM,ILIST(3),13) 
      CALL EXEC(2,ISKIP,ILIST,15) 
      CALL BLANC(ILIST,15)
      CALL MOVEW(JSTAR,ILIST(3),13) 
      CALL EXEC(2,ISKIP,ILIST,15) 
      CALL EXEC(3,1100B+ISKIP,1)
C 
C     FIND STORAGE STATE
C 
      I=38
      DO 6010 K=1,100 
      I=KFORM(I)
      IF(IAND(KFORM(I+1),140B).EQ.140B) GO TO 6020
6010  CONTINUE
      STOP 6010 
C 
C  FIND IMAGE STORAGE 
C 
6020  L=KFORM(I)
      I=I+2 
      DO 6030 J=1,4 
      M=IAND(KFORM(I),170000B)/4096 
      IF(M.EQ.5) GO TO 6040 
      IF(M.LT.4) I=I+6
      IF(M.EQ.4) I=I+4
6030  CONTINUE
      STOP 6030 
C 
C   PRINT INFORMATION 
C 
C   OPERATION AND DATA SET
C 
6040  N=IAND(KFORM(I),17B)
      IF(N.EQ.0) GO TO 6100 
      M=IAND(KFORM(I),1760B)/16 
      CALL BLANC(ILIST,23)
      CALL MOVEW(JDEL,ILIST(6),15)
      IF(N.EQ.1) CALL MOVEW(JAD,ILIST(7),3) 
      IF(N.EQ.2) CALL MOVEW(JUP,ILIST(7),3) 
      CALL DBINF(2HS ,2,M,IBUF) 
      IF(IBUF.NE.0) STOP 6041 
      CALL MOVEW(IBUF(2),ILIST(21),3) 
      CALL EXEC(2,ISKIP,ILIST,23) 
      IF(N.EQ.3) GO TO 6100 
C 
C  ITEMS TO BE ADDED OR UPDATED 
C 
      CALL EXEC(3,1100B+ISKIP,1)
      CALL BLANC(ILIST,23)
      CALL MOVEW(JITM,ILIST(16),4)
      I=I+1 
      IF(I.NE.L) GO TO 6050 
      L=KFORM(I)
      I=I+2 
6050  M=KFORM(I)
      DO 6080 K=1,M 
      I=I+1 
      IF(I.NE.L) GO TO 6070 
      L=KFORM(I)
      I=I+2 
6070  N=IAND(KFORM(I),377B) 
      CALL DBINF(2HI ,2,N,IBUF) 
      IF(IBUF.NE.0) STOP 6070 
      CALL MOVEW(IBUF(2),ILIST(21),3) 
      CALL EXEC(2,ISKIP,ILIST,23) 
      CALL BLANC(ILIST,23)
      I=I+1 
      IF(I.NE.L) GO TO 6080 
      L=KFORM(I)
      I=I+2 
6080  CONTINUE
C 
C  NEXT IMAGE OPERATION 
C 
      I=I+1 
      IF(I.NE.L) GO TO 6090 
      L=KFORM(I)
      I=I+2 
6090  CALL EXEC(3,1100B+ISKIP,1)
      GO TO 6040
C 
C  RETURN TO TGP14
C 
6100  INDIC=-1
      CALL EXEC(8,KNAM) 
C 
C************************************************************************ 
C 
C   INDIC = -1 CLOSE DATA BASE
C 
C***********************************************************************
C 
900   CALL DBCLS(0,ISTAT) 
999   END 
      END$