*
* $Id$
*
* $Log$
* Revision 1.1  1996/02/28 16:24:32  mclareni
* Initial revision
*
*
#include "hepdb/pilot.h"
#if defined(CERNLIB__P3CHILD)
* Ignoring t=dummy
#endif
      SUBROUTINE CDDONT (PATHN, IUDIV, LSUP, KEY, CHOPT, IRC)
*     =======================================================
*
************************************************************************
*                                                                      *
*        SUBR. CDDONT (PATHN, IUDIV, LSUP, KEY, CHOPT, IRC*)           *
*                                                                      *
*   Stores data from memory to disk. If data exist with the same user  *
*   keys, the old object is physically replaced. This mode is not      *
*   recommended for all calibration data.                              *
*                                                                      *
*   Arguments :                                                        *
*                                                                      *
*     PATHN    Character string describing the pathname                *
*     IUDIV    Division index of the user data bank                    *
*     LSUP     Address of bank in memory where data reside             *
*     KEY      Vector of keys                                          *
*     CHOPT    Character string with any of the following characters   *
*          B   Save in the special backup file; not in standard Journal*
*          H   Insertion time as supplied by user to be honoured       *
*     IRC      Return code (see below)                                 *
*                                                                      *
*   Called by user,   CDFZUP                                           *
*                                                                      *
*   Error Condition :                                                  *
*                                                                      *
*     IRC       =  0 : No error                                        *
*               = 71 : Illegal path name                               *
*               = 73 : RZ error during writing to disk                 *
*               = 76 : Cannot form the IO descriptor for the FZ header *
*               = 77 : FZOUT fails to write on to the sequential file  *
*                                                                      *
************************************************************************
*
#include "hepdb/caopts.inc"
#include "hepdb/cdcblk.inc"
#include "hepdb/cfzlun.inc"
#include "hepdb/ckkeys.inc"
#include "hepdb/ctpath.inc"
#if defined(CERNLIB__P3CHILD)
#include "hepdb/p3dbl3.inc"
#endif
      PARAMETER       (NLEVM=20)
CAV      DIMENSION       KEY(9), LSUP(9), KEYV(MXDMCK), NLCUR(NLEVM)
CAV      KEY should be at least 3*NOF1CK
      DIMENSION       KEY(*), LSUP(9), KEYV(MXDMCK), NLCUR(NLEVM)
      CHARACTER       CHOPT*(*), PATHN*(*), CHOPF*4, PATHY*80, PATHL*80
      CHARACTER       CFORM(6)*1, CHFOR*100, CHCUR(NLEVM)*1
      DATA            CFORM /'B', 'I', 'F', 'D', 'H', 'A'/
#include "zebra/q_jbit.inc"
* Ignoring t=pass
#include "zebra/q_sbit.inc"
* Ignoring t=pass
*
*     ------------------------------------------------------------------
*
* *** Decode the character option (no compression of data)
*
      LREFCD(1) = LSUP(1)
      CALL CDOPTS (CHOPT, IRC)
      IF (IRC.NE.0)             GO TO 999
      IOPYCA = 1
*
* *** Load top directory information; gets in PAT1CT complete path name
*
      CALL CDLDUP (PATHN, 1, IRC)
      IF (IRC.NE.0)             GO TO 999
      PATHY  = PAT1CT
      NCHAR  = LENOCC (PATHY)
      NWKEY  = NWKYCK
      PATHL  = ' '
      KST    = NWKYCK + 1
      CALL CDKYTG
      IF (NKEYCK.NE.0)  THEN
        IOPTP  = JBIT (IQ(KOFSCD+LCDRCD+IKDRCD+IDHFLG), JPRTCD)
      ELSE
        IOPTP  = 0
      ENDIF
*
* *** Load IPREC/DELTA from dictionary; choose the transcript file
*
      CALL CDLDIC (PATHY, 1, IRC)
      IF (IRC.NE.0)             GO TO 999
      IF (IOPBCA.EQ.0) THEN
        LUFZCF = LUFZCD
      ELSE
        LUFZCF = LUBKCD
      ENDIF
*
* *** Prepare the Key vector array
*
      CALL VZERO (KEYVCK, MXDMCK)
      DO 10 I = 1, NPARCD
        KEYVCK(NOF1CK+2*I-1) = KEY(NOF1CK+2*I-1)
        KEYVCK(NOF1CK+2*I)   = KEY(NOF1CK+2*I)
   10 CONTINUE
      KEYVCK(IDHUSI) = KEY(IDHUSI)
      IF (IOPHCA.NE.0) THEN
        KEYVCK(IDHINS) = KEY(IDHINS)
      ELSE
        CALL DATIME (IDATE, ITIME)
        CALL CDPKTM (IDATE, ITIME, KEYVCK(IDHINS), IRC)
      ENDIF
      IF (NWKYCK.GT.NSYSCK) THEN
        DO 15 NK = NSYSCK+1, NWKYCK
          IOKYCA(NK) = 1
          KEYVCK(NK) = KEY(NK)
   15   CONTINUE
      ENDIF
*
* *** Encode the character option, IO descriptor for the header
*
      IF (IOPPCD.NE.0.OR.LUFZCF.GT.0) THEN
        IF (IOPHCA.NE.0) THEN
          CHOPF  = 'H'//CHOPT
        ELSE
          CHOPF  = CHOPT
        ENDIF
        NDOP   = LENOCC (CHOPF)
        NDOP   = (NDOP + 3) / 4
*
        NLEV   = 1
        NCUR   = 5
        IFORO  = 2
        CHCUR(NLEV) = CFORM(IFORO)
        DO 20 I = 1, NWKYCK
          IFORM  = IOTYCK(I)
          IF (IFORM.EQ.6) IFORM = 5
          IF (IFORM.EQ.IFORO) THEN
            NCUR   = NCUR + 1
          ELSE
            NLCUR(NLEV) = NCUR
            IF (NLEV.GE.NLEVM) THEN
              IRC    = 76
#if defined(CERNLIB__DEBUG)
              IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDDONT : '//
     +        'Cannot get IO descriptor '//PATHY//''')', IARGCD, 0)
#endif
              GO TO 999
            ENDIF
            NLEV   = NLEV + 1
            CHCUR(NLEV) = CFORM(IFORM)
            NCUR   = 1
            IFORO  = IFORM
          ENDIF
   20   CONTINUE
        NLCUR(NLEV) = NCUR
*
#if !defined(CERNLIB_IBM)||!defined(CERNLIB__P3CHILD)
        WRITE (CHFOR, 2001) (NLCUR(I), CHCUR(I), I = 1, NLEV)
#endif
#if (defined(CERNLIB_IBM))&&(defined(CERNLIB__P3CHILD))
        CHFOR  = ' '
        II     = 1
        DO 25 I = 1, NLEV
          CALL UTWRIT (CHFOR(II:II+1), '(I2)', NLCUR(I))
          II     = II + 2
          CHFOR(II:II) = CHCUR(I)
          II     = II + 2
   25   CONTINUE
#endif
        II     = 4 *NLEV
        CHFOR = CHFOR(1:II)//' -H'
        CALL MZIOCH (IOFMCF, NWFMCF, CHFOR(1:II+3))
*
*  **   Complete the header
*
        NWDP   = (NCHAR + 3) / 4
        NWDH   = NWDP + NDOP + NWKYCK + 5
        IHEDCF(MACTCF) = 9
        IHEDCF(MNKYCF) = NWKYCK
        IHEDCF(MOPTCF) = NDOP
        IHEDCF(MPATCF) = NWDP
        IHEDCF(MPRECF) = 0
        IF (NDOP.GT.0)
     +    CALL UCTOH (CHOPF, IHEDCF(MPRECF+NWKYCK+1), 4, 4*NDOP)
        CALL UCTOH (PATHY, IHEDCF(MPRECF+NWKYCK+NDOP+1), 4, 4*NWDP)
        CALL UCOPY (KEYVCK, IHEDCF(MPRECF+1), NWKYCK)
      ENDIF
#if (defined(CERNLIB_UNIX)||defined(CERNLIB_IBMVM)||defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER))
*
      IF (IOPPCD.NE.0) THEN
#endif
#if (defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER))&&(!defined(CERNLIB__P3CHILD))&&(defined(CERNLIB__ONLINE))
        LUFZCF = LUFMCD
        CALL CDWLOK (IRC)
#endif
#if (defined(CERNLIB_UNIX)||defined(CERNLIB_IBMVM)||defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER))&&(!defined(CERNLIB__P3CHILD))&&(!defined(CERNLIB__ONLINE))
        CALL CDSTSV (TOPNCD, 0, IRC)
#endif
#if defined(CERNLIB__P3CHILD)
        LUFZCF = LODBP3
        RNDBP3 = 'CDDONT '
        NWDBP3 = 2
        CALL UCTOH ('JOURNAL ', IWDBP3, 4, 8)
        CALL CDCHLD
        IRC    = IQDBP3
#endif
#if (defined(CERNLIB_UNIX)||defined(CERNLIB_IBMVM)||defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER))
        IF (IRC.NE.0)           GO TO 999
      ENDIF
#endif
*
*  ** Write the sequential output if needed
*
      IF (LUFZCF.GT.0) THEN
        CALL FZOUT (LUFZCF, IUDIV, LREFCD(1), 1, 'L', IOFMCF, NWDH,
     +              IHEDCF)
        IF (IQUEST(1).NE.0) THEN
          IRC    = 77
#if defined(CERNLIB__DEBUG)
          IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDDONT : Error'//
     +    ' in FZOUT while writing Data for '//PATHY//''')', IARGCD, 0)
#endif
          GO TO 999
        ENDIF
      ENDIF
#if (defined(CERNLIB_UNIX)||defined(CERNLIB_IBMVM)||defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER))
*
      IF (IOPPCD.NE.0) THEN
#endif
#if (defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER))&&(!defined(CERNLIB__P3CHILD))&&(defined(CERNLIB__ONLINE))
*
        CALL CDCWSV (IRC)
#endif
#if (defined(CERNLIB_UNIX)||defined(CERNLIB_IBMVM)||defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER))
        GO TO 999
      ENDIF
#endif
#if !defined(CERNLIB__P3CHILD)
*
* *** Lock the directory if necessary
*
      IF (IOPPCD.EQ.0.AND.IOPSCD.NE.0) THEN
        CALL RZLOCK ('CDDONT')
        PATHL  = PATHY
      ENDIF
*
* *** Look if object already exists with similar user keys
*
      IF (IOPTP.EQ.0) THEN
        CALL CDHUNT (KEYV)
*
      ELSE
*
        NKEYS  = NKEYCK
        DO 30 JK = 1, NKEYS
          ICURCT = NKEYS + 1 - JK
          CALL CDPATH (TOP1CT, ICURCT)
          IF (JK.NE.1) THEN
            CALL RZCDIR (PATHY, ' ')
            IF (IQUEST(1).NE.0) GO TO 991
          ENDIF
*
          CALL RZCDIR (TOP1CT, ' ')
          IF (IQUEST(1).NE.0)   GO TO 991
          NKEYCK = IQUEST(7)
          LCDRCD = IQUEST(11)
          IKDRCD = IQUEST(13)
          CALL CDHUNT (KEYV)
          IF (KEYV(1).GT.0)     GO TO 35
*
   30   CONTINUE
*
      ENDIF
*
* *** Either update an old record
*
   35 IF (KEYV(1).GT.0) THEN
        CALL RZOUT (IUDIV, LREFCD(1), KEYV, ICYCLE, 'L')
        IER    = IQUEST(1)
        IKDRCD = IQ(KOFSCD+LCDRCD+KLKDCD)
        NKEYCK = IQ(KOFSCD+LCDRCD+KNKDCD)
        CALL RZPURG (0)
        IF (IER.NE.0) IQUEST(1) = IER
*
* *** Or enter a new one
*
      ELSE
*
*  **   Take necessary action for partitioned and nonpartitioned dataset
*
        IF (IOPTP.EQ.0) THEN
          KOBJ   = 0
        ELSE
          CALL RZCDIR (PATHY, ' ')
          LCDRCD = IQUEST(11)
          IKDRCD = IQUEST(13)
          KPNT   = IUHUNT (NKEYS, IQ(KOFSCD+LCDRCD+IKDRCD+MPSRCD),
     +                     NKEYS*KST, KST)
          IF (KPNT.NE.0) THEN
            NK     = (KPNT - MPSRCD) / KST + 1
          ELSE
            NK     = NKEYS
          ENDIF
          CALL CDKEYR (NK, NWKYCK, KYP1CK)
          KOBJ   = KYP1CK(MOBJCD)
          MXKP   = KYP1CK(MXKPCD)
          CALL CDPATH (TOP1CT, NKEYS)
          CALL RZCDIR (TOP1CT, ' ')
          IF (IQUEST(1).NE.0)   GO TO 991
          NKEYCK = IQUEST(7)
          LCDRCD = IQUEST(11)
          IKDRCD = IQUEST(13)
*
*  **     Make a different subdirectory if there are too many keys
*
          IF (NKEYCK.GE.MXKP) THEN
            CHFOR = ' '
            DO 40 I = 1, NWKYCK
              IF (I.EQ.1) THEN
                CHFOR  = CFORM(IOTYCK(I))
              ELSE
                CHFOR  = CHFOR(1:I-1)//CFORM(IOTYCK(I))
              ENDIF
   40       CONTINUE
            KEY7CK = KEYVCK(IDHINS)
            IF (ICMPCD.EQ.2) THEN
              CHOPF  = 'ZP'
            ELSE IF (ICMPCD.NE.0) THEN
              CHOPF = 'CP'
            ELSE
              CHOPF = 'P '
            ENDIF
            CALL CDMKDI (PATHY, NWKEY, CHFOR, CTAGCK, MXKP, IPRECD,
     +                   DELTCD, CHOPF, IRC)
            IF (IRC.NE.0)       GO TO 999
            CALL RZCDIR (PATHY, ' ')
            NKEYCK = IQUEST(7)
            LCDRCD = IQUEST(11)
            IKDRCD = IQUEST(13)
            KPNT   = IUHUNT (NKEYCK, IQ(KOFSCD+LCDRCD+IKDRCD+MPSRCD),
     +                       NKEYCK*KST, KST)
            IF (KPNT.NE.0) THEN
              NK     = (KPNT - MPSRCD) / KST + 1
            ELSE
              NK     = NKEYCK
            ENDIF
            CALL CDKEYR (NK, NWKYCK, KYP1CK)
            KOBJ   = KYP1CK(MOBJCD)
            CALL CDPATH (TOP1CT, NKEYCK)
            CALL RZCDIR (TOP1CT, ' ')
            IF (IQUEST(1).NE.0) GO TO 991
            NKEYCK = IQUEST(7)
            LCDRCD = IQUEST(11)
            IKDRCD = IQUEST(13)
          ENDIF
          CALL UCOPY (KYP1CK, KYP2CK, NWKYCK)
*
        ENDIF
*
*  **   Check the number of keys
*
        LOBJ   = KOBJ
        DO 45 IK = 1, NKEYCK
          IP     = KOFSCD + LCDRCD + IKDRCD + (IK-1)*KST + IDHKSN
          IF (IQ(IP).GT.LOBJ) LOBJ = IQ(IP)
   45   CONTINUE
        KEYVCK(IDHKSN) = LOBJ + 1
        KEYVCK(IDHFLG) = MSBIT1 (KEYVCK(IDHFLG), JRZUCD)
        CALL RZOUT (IUDIV, LREFCD(1), KEYVCK, ICYCLE, 'L')
        IKDRCD = IQ(KOFSCD+LCDRCD+KLKDCD)
        NKEYCK = IQ(KOFSCD+LCDRCD+KNKDCD)
        IER    = IQUEST(1)
        CALL CDPVAL (KEYVCK(1))
        CALL RZRENK (KYP1CK, KYP2CK)
        IF (IER.NE.0) IQUEST(1) = IER
      ENDIF
      IF (IQUEST(1).NE.0) THEN
        IRC    = 73
#endif
#if (defined(CERNLIB__DEBUG))&&(!defined(CERNLIB__P3CHILD))
        IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDDONT : Error i'//
     +    'n RZ while writing Data for '//PATHY//TOP1CT(1:8)//''')',I,0)
#endif
#if !defined(CERNLIB__P3CHILD)
      ENDIF
      GO TO 998
#endif
*
* *** Error messages
*
  991 IRC    = 71
#if defined(CERNLIB__DEBUG)
      IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDDONT : Illegal '//
     +  'Path Name '//PATHY//TOP1CT(1:8)//''')', IARGCD, 0)
#endif
#if !defined(CERNLIB__P3CHILD)
*
  998 IF (PATHL.NE.' ') THEN
        CALL RZCDIR (PATHL, ' ')
        CALL RZFREE ('CDDONT')
      ENDIF
#endif
#if !defined(CERNLIB_IBM)||!defined(CERNLIB__P3CHILD)
*
 2001 FORMAT (20(I2,A1,1X))
#endif
*                                                             END CDDONT
  999 END
