FTN4
      PROGRAM TGPI1(5), 92080-1X375 REV.2026  800212          
C 
C     SOURCE 92080-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(780) 
      COMMON JFORM(1700)
      COMMON MFORM(28)
      COMMON LFORM(42)
      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(2844)
      COMMON ILIBR(67)
      COMMON NIMAG
      COMMON IBASE(10)
C 
C************ LOCAL ARRAYS************* 
C 
      DIMENSION ILIST(46),ILEVL(3),INAM(3),IER(3),ISTAT(10) 
      DIMENSION JIM(15),JSTAR(15),JDEL(15),JUP(3),JAD(3),JITM(4)
      DIMENSION IMSTA(17),IBUF(128),JNAM(3),KBUF(16),IER1(3)
      DIMENSION LNAM(3),KNAM(3),JOP(17),IBASE0(10)
C 
      LOGICAL ISBIT,INUM
C 
C *********** DATA ASSIGNMENTS *****************
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 ,2HMO,2HDI,2HFI,2HCA,2HTI,2HON,2HS , 
     C2HDE,2HFI,2HNE,2HD ,2H: / 
      DATA JSTAR/2H**,2H**,2H**,2H**,2H**,2H**,2H**,2H**,2H**,2H**, 
     C2H**,2H**,2H**,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 
C100   ILIST(1)=15
C     CALL DBINT(IFORM(38),ISKIP,ILIST,ISTAT) 
C     IF(ISTAT.NE.0) GO TO 3000 
100   CALL DBOPN(IBASE,IFORM(770),1,ISTAT)
C     -130 IF SUCCESSFUL OPEN.
      IF(ISTAT(1).EQ.0 .AND. ISTAT(2).EQ.15) GO TO 130
C 
C     -ERROR IN DBOPN 
C 
      GO TO 3000
C 
C  THE DATA BASE IS SUCCESSFULY OPENED RETURN TO TGP1 SEGMENT 
C 
130   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,17 
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(IBASE,IMSTA(I+1),202,ISTAT,IBUF) 
      IF(ISTAT.NE.0) GO TO 3000 
      IF(IGET1(IBUF,17).NE.1HM) GO TO 530 
C     -ERR IF DS ACCESSED > 512 WORDS/RECORD (TMS LIMITATION).
      IF(IBUF(10).GT.512) GO TO 3006
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 
C  IKFLG IS FLAG SET IF KEY ITEM IS FOUND IN THE FORM 
C 
C     "GET KEY FROM MASTER" 
      CALL DBINF(IBASE,IMSTA(I+1),302,ISTAT,IBUF) 
      IF(ISTAT.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(1)) IKFLG=1
C 
C     -STRING?
      IF(IAND(IMAI(J,2),30000B).NE.0) GO TO 515 
C     -YES.  CONVERT LENGTH TO WORDS. 
      KFORM(N3)=IALF2((IAND(IMAI(J,4),377B)/2)) 
      GO TO 518 
C 
C     -INTEGER? 
515   IF(.NOT.ISBIT(IMAI(J,2),12)) GO TO 516
C     -YES.  LENGTH = 1 WORD. 
      KFORM(N3)=400B
      GO TO 518 
C 
C     -REAL.  LENGTH = 2 WORDS. 
516   KFORM(N3)=1000B 
      GO TO 518 
C 
518   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(1) 
D     PAUSE 520 
      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 5350 I=1,IMSTA 
      CALL DBINF(IBASE,IMSTA(I+1),202,ISTAT,IBUF) 
      IF(ISTAT.NE.0) GO TO 3000 
      IF(IGET1(IBUF,17).NE.1HD) GO TO 5350
C 
C  HAVE A DETAIL DATA SET... NOW MAKE SURE ALL SORT 
C  ITEMS HAVE BEEN SPECIFIED
C 
      CALL DBINF(IBASE,IMSTA(I+1),301,ISTAT,IBUF) 
      IF(ISTAT.NE.0) GO TO 3000 
      DO 5351 I2=1,IBUF(1)
      IF(IBUF(3*I2+1).EQ.0) GO TO 5351
      IFLAGX=0
      DO 5352 I3=1,44 
      IF(IAND(IMAI(I3,1),377B).EQ.IBUF(3*I2+1) .AND.
     . (IAND(IMAI(I3,2),7B).EQ.0 .OR. 
     .  IAND(IMAI(I3,2),7B).EQ.1 .OR. 
     .  IAND(IMAI(I3,2),7B).EQ.2 .OR. 
     .  IAND(IMAI(I3,2),7B).EQ.3 .OR. 
     .  IAND(IMAI(I3,2),10B).NE.0)) IFLAGX=1
5352  CONTINUE
C 
C  IF IFLAGX=0 NO FUNCTION HAS BEEN PERFORMED WITH THE
C  SORT ITEM...PRINT OUT AN ERROR MESSAGE 
C 
      IF(IFLAGX.NE.0) GO TO 5351
      IMES=5
      ITN=IBUF(3*I2+1)
      GO TO 2900
5351  CONTINUE
5350  CONTINUE
C 
C  NEED TO ISOLATE THE DETAIL DATA SETS AGAIN FOR ADD CHECKING
C 
      DO 800 I=1,IMSTA
      CALL DBINF(IBASE,IMSTA(I+1),202,ISTAT,IBUF) 
      IF(ISTAT.NE.0) GO TO 3000 
      IF(IGET1(IBUF,17).NE.1HD) GO TO 800 
C     -ERR IF DS ACCESSED > 512 WORDS/RECORD (TMS LIMITATION).
      IF(IBUF(10).GT.512) GO TO 3006
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 DETAIL DATA SET
C   STORE THEM IN IBUF
C 
C     "GET MASTERS LINKED TO THIS DETAIL" 
      CALL DBINF(IBASE,IMSTA(I+1),301,ISTAT,IBUF) 
      IF(ISTAT.NE.0) GO TO 3000 
C     "IBUF NOW CONTAINS ALL THE KEY ITEMS FOR DETAIL DS IMSTA(I+1)"
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(1)
C     -TO START WITH, SET IOP TO ADD. 
      IOP=2 
540   ITN=IBUF(3*J) 
      K=ILIN(IMAI,ITN,IMSTA(I+1),IOP) 
      IF(K.NE.-1) GO TO 560 
      CALL ITEQU(ITN,IMSTA(I+1),KBUF,IBASE) 
      DO 550 L=1,16 
         IF(KBUF(L).EQ.0) GO TO 550 
            ITNL=IAND(KBUF(L),377B) 
            IDSL=IAND(KBUF(L),177400B)/256
            K=ILIN(IMAI,ITNL,IDSL,IOP)
            IF(K.NE.-1) GO TO 560 
550   CONTINUE
C     -ADD? 
      IF(IOP.EQ.2) GO TO 551
C     -DISPLAY? 
      IF(IOP.EQ.5) GO TO 552
C     -FIND?
      IF(IOP.EQ.0) GO TO 553
D     PAUSE 550 
      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 
C 
C     -STRING?
      IF(IAND(IMAI(K,2),30000B).NE.0) GO TO 565 
C     -YES.  CONVERT LENGTH TO WORDS. 
      KFORM(N3)=IALF2((IAND(IMAI(K,4),377B)/2)) 
      GO TO 575 
C 
C     -INTEGER? 
565   IF(.NOT.ISBIT(IMAI(K,2),12)) GO TO 570
C     -YES.  LENGTH = 1 WORD. 
      KFORM(N3)=400B
      GO TO 575 
C 
C     -REAL.  LENGTH = 2 WORDS. 
570   KFORM(N3)=1000B 
      GO TO 575 
C 
575   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 
C 
C     -STRING?
      IF(IAND(IMAI(J,2),30000B).NE.0) GO TO 615 
C     -YES.  CONVERT LENGTH TO WORDS. 
      KFORM(N3)=IALF2((IAND(IMAI(J,4),377B)/2)) 
      GO TO 618 
C 
C     -INTEGER? 
615   IF(.NOT.ISBIT(IMAI(J,2),12)) GO TO 616
C     -YES.  LENGTH = 1 WORD. 
      KFORM(N3)=400B
      GO TO 618 
C 
C     -REAL.  LENGTH = 2 WORDS. 
616   KFORM(N3)=1000B 
      GO TO 618 
C 
618   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(IBASE,ITN,102,ISTAT,IBUF)
      IF(ISTAT.NE.0) GO TO 3000 
      CALL MOVEW(IBUF(1),IER,3) 
      CALL DBINF(IBASE,IMSTA(I+1),202,ISTAT,IBUF) 
      IF(ISTAT.NE.0) GO TO 3000 
      CALL MOVEW(IBUF(1),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=8 
C     -MSG6 IF USER DOES NOT HAVE HIGHEST LEVEL ACCESS WORD 
      IF(ISTAT(1).EQ.0 .AND. ISTAT(2).NE.15) GO TO 3005 
C     -SEE IMAGE MANUAL FOR THESE DBOPEN ERRORS.
      IF(ISTAT.EQ.32)  IMES=14
      IF(ISTAT.EQ.116) IMES=9 
      IF(ISTAT.EQ.117) IMES=1 
      IF(ISTAT.EQ.119) IMES=2 
      IF(ISTAT.EQ.128) IMES=10
      IF(ISTAT.EQ.129) IMES=3 
      IF(ISTAT.EQ.131) IMES=11
      IF(ISTAT.EQ.150) IMES=12
      IF(ISTAT.EQ.152) IMES=13
      IF(ISTAT.EQ.117) IMES=1 
      GO TO 3010
C 
C     -MUST RE-CLOSE THE DATA BASE BEFORE RETURNING TO SCREEN 4 
C 
3005  CALL DBCLS(IBASE,ID,1,ISTAT)
      IF(ISTAT.NE.0) GO TO 3000 
      NOF=11
      IMES=6
      GO TO 3010
C 
C-----"DATA SET ACCESSED > 512 WORDS/RECORD"
C 
3006  IMES=7
      GO TO 3010
C 
C  A SPECIAL MESSAGE EXISTS 
C 
3010  IF(IMES.EQ.0) GO TO 3020
      IF(IMES.EQ.1)  NOF=9
      IF(IMES.EQ.14) NOF=10 
      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 
C    -BUILD THE DATA BASE NAMR & STORE IT INTO IBASE BEFORE CALLING TGP11 
      DO 5257 I=1,10
         IBASE0(I)=2H 
         IBASE(I)=2H
5257  CONTINUE
C    -BYTES 1,2 : DS NODE (NOT YET IMPLEMENTED) 
      IBASE0(1)=2H
C    -BYTES 3-7 : DB NAME 
      CALL MOVCA(IFORM,75,IBASE0,3,5) 
C    -BYTE 8 : COLON
      CALL PUTCA(IBASE0,1H:,8)
C    -BYTES 9-13 : SECURITY CODE
      CALL MOVCA(IFORM,81,IBASE0,9,5) 
C    -BYTE 14 : COLON 
      CALL PUTCA(IBASE0,1H:,14) 
C    -BYTES 15-19 : CR# 
      CALL MOVCA(IFORM,1534,IBASE0,15,5)
C    -BYTE 20 : SEMI-COLON
      CALL PUTCA(IBASE0,1H;,20) 
C     -NOW PACK IBASE ELIMINATING IMBEDDED BLANKS.
      K=3 
      DO 5258 I=2,20
         J=IGET1(IBASE0,I)
         IF(J.EQ.1H ) GO TO 5258
         CALL PUTCA(IBASE,J,K)
         K=K+1
5258  CONTINUE
      CALL DBOPN(IBASE,IFORM(770),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),15) 
      CALL EXEC(2,ISKIP,ILIST,17) 
      CALL BLANC(ILIST,15)
      CALL MOVEW(JSTAR,ILIST(3),15) 
      CALL EXEC(2,ISKIP,ILIST,17) 
      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(IBASE,M,202,ISTAT,IBUF)
      IF(ISTAT.NE.0) STOP 6041
      CALL MOVEW(IBUF(1),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(IBASE,N,102,ISTAT,IBUF)
      IF(ISTAT.NE.0) STOP 6070
      CALL MOVEW(IBUF(1),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(IBASE,ID,1,ISTAT)
999   END 
C 
C 
D     SUBROUTINE EDUMP(NERR,ITN,IDS,KBUF,ISTAT,IBUF)
D     DIMENSION KBUF(1),ISTAT(1),IBUF(1)
D     WRITE(6,145) NERR,ITN,IDS 
D     WRITE(6,154) (KBUF(I),I=1,5)
D     WRITE(6,150) (ISTAT(I),I=1,10)
D     WRITE(6,151) (ISTAT(I),I=1,10)
D     WRITE(6,152) (IBUF(I),I=1,10) 
D     WRITE(6,152) (IBUF(I),I=11,20)
D     WRITE(6,152) (IBUF(I),I=21,30)
D     WRITE(6,153) (IBUF(I),I=1,10) 
D     WRITE(6,153) (IBUF(I),I=11,20)
D     WRITE(6,153) (IBUF(I),I=21,30)
D145   FORMAT("0NERR=",I7," : ITN=",I7," : IDS=",I7)
D150   FORMAT(" ISTAT@=",10@7)
D151   FORMAT(" ISTATA=",10A2)
D152   FORMAT(" IBUF@7=",10@7)
D153   FORMAT(" IBUFI7=",10I7)
D154   FORMAT(" KBUFI7=",5I7) 
D     RETURN
C 
D     END 
      END$