*
* $Id$
*
* $Log$
* Revision 1.2  1999/08/17 12:42:31  mclareni
* Y2k mods submitted by Rob Komar
*
* Revision 1.1.1.1  1996/02/28 16:24:08  mclareni
* Hepdb, cdlib, etc
*
*
#include "hepdb/pilot.h"
#if !defined(CERNLIB__P3CHILD)
      SUBROUTINE CDCDIC (PATHX, ICMPF, IPREC, DELTA, IRC)
*     ===================================================
*
************************************************************************
*                                                                      *
*        SUBR. CDCDIC (PATHX, ICMPF, IPREC, DELTA, IRC*)               *
*                                                                      *
*   Create or updates the dictionary table for the Data base file      *
*                                                                      *
*   Arguments :                                                        *
*                                                                      *
*     PATHX    Path name of the subdirectory                           *
*     ICMPF    Compression flag (0 no compression; 1 standard          *
*              compression using IPREC; 2 compression with zero        *
*              supression with DELTA)                                  *
*     IPREC    Precision word; (If IPREC > 0, data are stored with     *
*              IPREC significant digits right to the decimal points;   *
*              if IPREC < 0, data are stored with IPREC insignificant  *
*              digits left to the decimal point.)                      *
*     DELTA    Variable specifying the absolute value below which data *
*              is treated as zero                                      *
*     IRC      Return code (see below)                                 *
*                                                                      *
*   Called by CDMKDI                                                   *
*                                                                      *
*   Error Condition :                                                  *
*                                                                      *
*     IRC       =  0 : No error                                        *
*               =142 : Error in RZ in writing the dictionary object    *
*               =143 : Error in RZ in purging the dictionary directory *
*               =144 : Dictionary directory cannot be loaded           *
*               =145 : Pathname already exists in dictionary           *
*                                                                      *
************************************************************************
*
#include "hepdb/cdcblk.inc"
#include "hepdb/ckkeys.inc"
#include "hepdb/ctpath.inc"
      CHARACTER       PATHD*80, PATHX*(*)
*
*     ------------------------------------------------------------------
*
* *** The top directory information is assumed to be loaded
*     Top directory name is TOPNCD and LBUPCD the address of UPCD bank
*
      CALL RZCDIR (PAT3CT, 'R')
*
* *** Get the name of the name of directory without top name
*
      NCH    = LENOCC (PAT3CT)
      PAT3CT = PAT3CT(1:NCH)//'/'//PATHX
      CALL CDWTOP (PAT3CT, PAT2CT, NCHR)
      PATHD  = '//'//TOPNCD(1:NCHRCD)//'/'//'DICTIONARY'
      IF (IOUTCD.EQ.0) IOPSCD = 0
*
* *** Load the dictionary directory again just as a safe measure
*
      CALL RZCDIR (PATHD, ' ')
      IF (IQUEST(1).NE.0) THEN
        IRC    = 144
#if defined(CERNLIB__DEBUG)
        IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDCDIC : Cannot '//
     +  'set current directory to '//PATHD//''')', IARGCD, 0)
#endif
        GO TO 999
      ENDIF
*
      NKEYCK = IQUEST(7)
      NWKYCK = IQUEST(8)
      LCDRCD = IQUEST(11)
      IKDRCD = IQUEST(13)
      ISTP   = NWKYCK + 1
      IF (NKEYCK.GT.0) THEN
        IPNT   = KOFSCD + LCDRCD + IKDRCD
        IMIN   = IUHUNT (-1, IQ(IPNT+IDHKSN), NKEYCK*ISTP, ISTP)
        IF (IMIN.GT.0) THEN
          IMIN   = (IMIN - IDHKSN) / ISTP + 1
          CALL CDKEYT
          CALL CDKEYR (IMIN, NWKYCK, KEYNCK)
          LFIXCD = LQ(KOFUCD+LBUPCD-KLDICD)
          IF (LFIXCD.NE.0) CALL MZDROP (IDIVCD, LFIXCD, ' ')
          ICYCL  = 9999
          CALL CDRZIN (IDIVCD, LBUPCD, -KLDICD, IMIN, ICYCL, PATHD, IRC)
          IF (IRC.NE.0) GO TO 999
          LFIXCD = LQ(KOFUCD+LBUPCD-KLDICD)
          NDWD   = IQ(KOFUCD+LFIXCD-1)
          GO TO 10
        ENDIF
      ENDIF
*
* *** Recreate the dictionary directory
*
      CALL VZERO (KEYNCK, NSYSCK)
      KEYNCK(IDHKSN) = -1
      KEYNCK(IDHFLG) = 1
      CALL DATIME (IDATE, ITIME)
      CALL CDPKTM (IDATE,  ITIME,  KEYNCK(IDHINS), IRC)
      LFIXCD = LQ(KOFUCD+LBUPCD-KLDICD)
      IF (LFIXCD.NE.0) CALL MZDROP (IDIVCD, LFIXCD, ' ')
      NDWD   = NPUSCD*NWITCD + 1
      CALL CDBANK (IDIVCD, LFIXCD, LBUPCD, -KLDICD, 'DICD', 0, 0, NDWD,
     +             IODICD, 0, IRC)
      IF (IRC.NE.0)           GO TO 999
*
* *** Check if the path name already exists in the dictionary
*
   10 NITEM  = IQ(KOFUCD+LFIXCD+MDCNTM)
      NKEEP  = (NDWD - 1) / NWITCD
      NFREE  = 0
      IF (NITEM.GT.0) THEN
        DO 50 I = 1, NITEM
          IPNT   = KOFUCD + LFIXCD + (I - 1) * NWITCD + 1
          NCHF   = IQ(IPNT+MDCNCH)
          IF (IQ(IPNT+MDCITM).LE.0) THEN
            IF (NFREE.EQ.0) NFREE = I
          ELSE
            IF (NCHR.EQ.NCHF) THEN
              CALL UHTOC (IQ(IPNT+MDCNAM), 4, PAT3CT, NCHF)
              IF (PAT2CT(1:NCHR).EQ.PAT3CT(1:NCHF)) THEN
                IRC        = 145
                IQUEST(11) = I
#if defined(CERNLIB__DEBUG)
                IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDCDIC :'//
     +          ' Path name '//PAT2CT//' already in dictionary'')',IQ,0)
#endif
                GO TO 999
              ENDIF
            ENDIF
          ENDIF
   50   CONTINUE
      ENDIF
*
* *** Enter the new path name in the dictionary
*
      IF (NFREE.EQ.0) THEN
        NITEM  = NITEM + 1
        NFREE  = NITEM
        IF (NITEM.GT.NKEEP) THEN
          CALL ZSHUNT (IDIVCD, LFIXCD, LBDACD, 2, 0)
          LBDACD = LFIXCD
          LFIXCD = 0
          ND     = NDWD + NPUSCD * NWITCD
          CALL CDBANK (IDIVCD, LFIXCD, LBUPCD, -KLDICD, 'DICD', 0,0, ND,
     +                 IODICD, -1, IRC)
          IF (IRC.NE.0) THEN
            CALL MZDROP (IDIVCD, LBDACD, ' ')
            GO TO 999
          ENDIF
          CALL UCOPY (IQ(KOFUCD+LBDACD+1), IQ(KOFUCD+LFIXCD+1), NDWD)
          CALL MZDROP (IDIVCD, LBDACD, ' ')
        ENDIF
        IQ(KOFUCD+LFIXCD+MDCNTM) = NITEM
      ENDIF
      IPNT   = KOFUCD + LFIXCD + (NFREE - 1) * NWITCD + 1
      IQ(IPNT+MDCITM) = NFREE
      IQ(IPNT+MDCNCH) = NCHR
      IQ(IPNT+MDCLUP) = 0
      IQ(IPNT+MDCCMP) = ICMPF
      IQ(IPNT+MDCPRC) = IPREC
       Q(IPNT+MDCDEL) = DELTA
      CALL UCTOH ('        ', IQ(IPNT+MDCALI), 4, 8)
      CALL UCTOH (PAT2CT, IQ(IPNT+MDCNAM), 4, MAXLCD)
*
* *** Now update the disk file
*
      IF (IOPSCD.NE.0) CALL RZLOCK ('CDCDIC')
      CALL RZOUT (IDIVCD, LFIXCD, KEYNCK, ICYCLE, 'S')
      IF (IQUEST(1).NE.0) THEN
        IF (IOPSCD.NE.0) CALL RZFREE ('CDCDIC')
        IRC    = 142
#if defined(CERNLIB__DEBUG)
        IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDCDIC : RZOUT '//
     +  'error for path name '//PATHD//''')', IARGCD, 0)
#endif
        GO TO 999
      ENDIF
      IKDRCD = IQ(KOFSCD+LCDRCD+KLKDCD)
      NKEYCK = IQ(KOFSCD+LCDRCD+KNKDCD)
      CALL RZPURG (0)
      IERR   = IQUEST(1)
      IF (IOPSCD.NE.0) CALL RZFREE ('CDCDIC')
      IF (IERR.NE.0) THEN
        IRC    = 143
#if defined(CERNLIB__DEBUG)
        IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDCDIC : RZPURG '//
     +  'error for path name '//PATHD//''')', IARGCD, 0)
#endif
        GO TO 999
      ENDIF
*
  998 IRC    = 0
*                                                             END CDCDIC
  999 END
#endif
