*
* $Id$
*
* $Log$
* Revision 1.1  1996/02/28 16:23:53  mclareni
* Initial revision
*
*
#include "hepdb/pilot.h"
      PROGRAM CEXAM11
*
************************************************************************
*
*        PROG. CEXAM11
*
*   Provides facility to enter information into data base from an input
*   file. It operates with 2 FFKEY data cards 'IOPA' to specify the
*   input and output (data base) files and 'DIRE' to specify the name
*   of the directory and when needed the specification of user keys.
*
*   External routines : CDCRBK, CDLOKF, HEPDB routines
*   External libraries : PACKLIB, KERNLIB
*
************************************************************************
*
      PARAMETER       (NLAST=150000, NDIV1=5000)
      COMMON /GCBANK/ NZEBRA, GVERSN, ZVERSN, IXSTOR, IXDIV, IXCONS
     +              , FENDQ(16), LMAIN, LR1, WS(NLAST)
      DIMENSION       IQ(2), Q(2), LQ(8000)
      EQUIVALENCE     (Q(1),IQ(1),LQ(9)), (LQ(1),LMAIN,LBKS)
*
      COMMON /QUEST/  IQUEST(100)
*
      COMMON /CUSERB/ LKBKCU, LLBKCU
*
      PARAMETER       (NBUFF=50, NBDIR=20, NBKEY=20)
      DIMENSION       LBUFF(NBUFF), LBDIR(NBDIR), LBKEY(NBKEY)
      CHARACTER       CHINP*4, CHDBL*4, CHOPT*4, TOPN*16, CHDIR*80
      CHARACTER       CHNAM*80, CHFOR*100, CTAG(100)*8, CHVL*4
      PARAMETER       (NOFF1=10, NOFF2=12, IDHINS=4)
      INTEGER         KEYS(100)
*
*     ------------------------------------------------------------------
*
* *** Initialize ZEBRA
*
      CALL MZEBRA (-1)
      CALL MZSTOR (IXSTOR, '/GCBANK/', ' ', FENDQ(1), LQ(1), LQ(1)
     +           , LQ(1), LQ(NDIV1), LQ(NLAST))
      CALL MZDIV  (IXSTOR, IXCONS, 'Constant', 10000, NLAST-5000, 'L')
      IXDIV  = IXSTOR + 2
      CALL MZLINK (IXSTOR, '/CUSERB/', LKBKCU, LLBKCU, LLBKCU)
*
* *** Initialize FFREAD
*
      LPRNT  = 6
      CALL FFINIT (0)
      LUNIN  = 0
      LUNDB  = 0
      CALL VBLANK (LBUFF, NBUFF)
      CALL VBLANK (LBDIR, NBDIR)
      CALL VBLANK (LBKEY, NBKEY)
      CALL FFKEY  ('IOPA', LBUFF, NBUFF, 'MIXED')
      CALL FFKEY  ('DIRE', LBDIR, NBDIR, 'MIXED')
      CALL FFKEY  ('KYCH', LBKEY, NBKEY, 'MIXED')
      CALL FFGO
*
* *** Find the name of the directory and hence Top dir name
*
      CALL UHTOC (LBDIR(1), 4, CHNAM, 80)
      IF (CHNAM(1:2).NE.'//') THEN
        WRITE (LPRNT, *) ' CEXAM11 : No valid directory name given'
        GO TO 999
      ENDIF
      LNB     = INDEX (CHNAM, ' ')
      IF (LNB.GT.1) THEN
        CHDIR  = CHNAM(1:LNB-1)
      ELSE
        CHDIR  = CHNAM
      ENDIF
      NCHAR  = LENOCC (CHDIR)
      NCHRT  = INDEX  (CHDIR(3:NCHAR), '/') - 1
      IF (NCHRT.LE.0) NCHRT = NCHAR - 2
      TOPN   = CHDIR(3:NCHRT+2)
*
* *** Open the i/p and o/p files
*
      CALL CDLOKF ('INPU', LBUFF, NBUFF, I)
      IF (I.GT.0) THEN
        I      = I + 1
        LUNIN  = IABS (LBUFF(I))
        IF (LBUFF(I).LT.0) I = I + 2
        CALL UHTOC (LBUFF(I+1), 4, CHFOR, 80)
        LNB    = INDEX (CHFOR, ' ')
        CHNAM  =  CHFOR(2:LNB)
#if defined(CERNLIB_APOLLO)||defined(CERNLIB_UNIX)
        CALL CUTOL (CHNAM)
#endif
        CALL CDOPFL (LUNIN,  CHNAM, 'OLD', IRC)
        IF (IRC.NE.0) LUNIN = 0
      ENDIF
*
      CALL CDLOKF ('DBL3', LBUFF, NBUFF, I)
      IF (I.GT.0) THEN
        I      = I + 1
        LUNDB  = IABS (LBUFF(I))
        IF (LBUFF(I).LT.0) THEN
          I      =  I + 1
          CALL UHTOC (LBUFF(I), 4, CHDBL, 4)
          I      =  I + 1
          LRCDB  = LBUFF(I)
          I      =  I + 1
          LXTDB  = LBUFF(I)
          I      =  I + 1
          CALL UHTOC (LBUFF(I), 4, CHOPT, 4)
        ELSE
          CHDBL  = 'RO  '
          LRCDB  = 4096
          LXTDB  = 4096
          CHOPT  = 'U   '
        ENDIF
        CALL UHTOC (LBUFF(I+1), 4, CHFOR, 80)
        LNB    = INDEX (CHFOR, ' ')
        CHNAM  =  CHFOR(2:LNB)
        CALL CDROPN (LUNDB, CHDBL, CHNAM, LRCDB, IRC)
        IF (IRC.NE.0) LUNDB = 0
      ENDIF
*
      IF (LUNIN.EQ.0.OR.LUNDB.EQ.0) THEN
        WRITE (LPRNT, *) ' CEXAM11 : Error in opening the files'
        GO TO 999
      ENDIF
*
* *** Initialize the Database
*
      NPAIR = 1
      LUFZ  = 0
      NTOP  = 0
      CALL CDINIT (IDIVCU, LUNDB, LUFZ, TOPN, NPAIR, LXTDB, NTOP,
     +             CHOPT, IRC)
      CALL CDLOGL (TOPN,  1, ' ', IRC)
      CALL UOPTC  (CHOPT, 'Z', II)
*
* *** See if directory creation is necessary
*
      IF (II.GT.0) THEN
        ICREA   = 1
      ELSE
        CALL RZCDIR (CHDIR, ' ')
        IF (IQUEST(1).EQ.0) THEN
          ICREA  = 0
          NWKEY  = IQUEST(8)
        ELSE
          ICREA  = 1
        ENDIF
      ENDIF
*
* *** Find the number of user keys and create directory
*
      IF (ICREA.GT.0) THEN
        NUKYS   = 0
        CHFOR   = ' '
        CTAG(1) = ' '
        CALL CDLOKF ('KEYS', LBDIR, NBDIR, I)
   10   IF (I.GT.0 .AND. I.LE.NBDIR-3) THEN
          I      = I + 1
          CALL UHTOC (LBDIR(I), 4, CTAG(NUKYS+1), 8)
          IF (CTAG(NUKYS+1).NE.'        ') THEN
            I      = I + 2
            CALL UHTOC (LBDIR(I), 4, CHVL, 4)
            IF (CHVL(1:1).NE.'I'.AND.CHVL(1:1).NE.'B'.AND.
     +          CHVL(1:1).NE.'H'.AND.CHVL(1:1).NE.'A') CHVL(1:1) = 'I'
            IF (NUKYS.GT.0) THEN
              CHFOR  = CHFOR(1:NUKYS)//CHVL(1:1)
            ELSE
              CHFOR  = CHVL(1:1)
            ENDIF
            NUKYS  = NUKYS + 1
            GO TO 10
          ENDIF
        ENDIF
        IPREC  = 0
        DELTA  = 0.
        CALL CDMDIR (CHDIR, NUKYS, CHFOR, CTAG, 0, IPREC,DELTA, 'C',IRC)
        NWKEY  = NUKYS + NOFF2
        IF (IQUEST(1).NE.0) THEN
          WRITE (LPRNT, *) ' CEXAM11 : Error ', IQUEST(1),
     +                      ' in creating directory'
          GO TO 50
        ENDIF
      ENDIF
*
* *** Now call user routine to prepare the data base object
*
      CALL VZERO  (KEYS, NWKEY)
      CALL CDCRBK (LUNIN, LPRNT, KEYS)
*
* *** Update some of the keys
*
      IK    = 1
   20 IF (IK.LT.NBKEY) THEN
        IF (LBKEY(IK).GT.0.AND.LBKEY(IK).LE.NWKEY) THEN
          IKEY   = LBKEY(IK)
          IF (IKEY.EQ.NOFF1+1.OR.IKEY.EQ.NOFF1+2) THEN
            CALL DBPKTS (LBKEY(IK+1), LBKEY(IK+2), KEYS(IKEY), IRC)
            IK     = IK + 3
          ELSE IF (IKEY.EQ.IDHINS) THEN
            CALL DBPKTM (LBKEY(IK+1), LBKEY(IK+2), KEYS(IKEY))
            IK     = IK + 3
          ELSE
            KEYS(IKEY) = LBKEY(IK+1)
            IK     = IK + 2
          ENDIF
          GO TO 20
        ENDIF
      ENDIF
*
* *** Enter it in Data base
*
      CALL CDSTOR (CHDIR, LKBKCU, LLBKCU, IXDIV, KEYS, 'DY', IRC)
      WRITE (LPRNT, *) ' CEXAM11 : Data entered in ', CHDIR(1:NCHAR)
      WRITE (LPRNT, *) '           Error code      ', IRC
*
* *** Close data base and exit
*
   50 CALL CDEND  ('*', 'A', IRC)
      CALL MZEND
*                                                            END CEXAM11
  999 END
