* * $Id: cdentb.F,v 1.1.1.1 1996/02/28 16:24:33 mclareni Exp $ * * $Log: cdentb.F,v $ * Revision 1.1.1.1 1996/02/28 16:24:33 mclareni * Hepdb, cdlib, etc * * #include "hepdb/pilot.h" #if defined(CERNLIB__P3CHILD) * Ignoring t=dummy #endif SUBROUTINE CDENTB (PATHN, LSUP,IUDIV, NWDIM,NOBJ, KEY, CHOPT, IRC) * ================================================================== * ************************************************************************ * * * SUBR. CDENTB (PATHN, LSUP,IUDIV, NWDIM,NOBJ,KEY, CHOPT, IRC*) * * CHOPT) * * * * Stores data from memory to disk for a number of objects in a go. * * It is useful in a Batch operation to save real time spent * * * * Arguments : * * * * PATHN Character string describing the pathname * * LSUP Vector containing the addresses of the banks where * * data reside * * IUDIV Division index where the data reside * * NWDIM First dimension of the array KEY * * NOBJ Number of objects to be inserted * * KEY Two dimensional array with the first dimension NWDIM, * * specifying the key elements for each object and the * * secod dimension NOBJ, specifying the number of objects * * (Keys 3,4,5 and 8 onwards to be filled in by user on * * input; the DB system keys will be filled in here at the * * time of output) * * CHOPT Character string with any of the following characters * * B Save in the special backup file; not in standard Journal* * D Store only the differences from an existing object * * F Updates with a fully matched data object (in user keys) * * K Store data only inside the keys (not yet installed) * * H Insertion time as supplied by user to be honoured * * P Store data compressed (bit packing) * * T Special text type of data (to be used with R) * * Y Store with full RZ option (No compression to be made) * * Z Store only nonzero elements. An element is considered to* * to be zero if its absolute value is less than DELTA * * IRC Return code (see below) * * * * Called by user, CDSTOM * * * * Error Condition : * * * * IRC = 0 : No error * * = 61 : Illegal number of keys (NWDIM < NWKEY) * * = 71 : Illegal path name * * = 73 : RZOUT fails to write on disk * * = 74 : Error in RZRENK in updating key values for * * partitioned data set * * = 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/cinitl.inc" #include "hepdb/ckkeys.inc" #include "hepdb/clinks.inc" #include "hepdb/ctpath.inc" #include "hepdb/czpack.inc" #if defined(CERNLIB__P3CHILD) #include "hepdb/p3dbl3.inc" #endif PARAMETER (NLEVM=20) INTEGER NLCUR(NLEVM) DIMENSION KEY(NWDIM,2), LSUP(9) CHARACTER PATHY*80, PATHX*16, CHFOR*100, CFORM(6)*1 CHARACTER CHCUR(NLEVM)*1, CHOP*1 CHARACTER PATHN*(*), CHOPT*(*), CHOP0*80, PATHL*80 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 * CALL CDOPTS (CHOPT, IRC) IF (IRC.NE.0) GO TO 999 * IF (IOPFCA.NE.0) IOPDCA = 1 IF (IOPTCA.NE.0) IOPYCA = 1 IF (IOPYCA.NE.0) THEN IOPPCA = 0 IOPZCA = 0 ENDIF IF (IOPPCA.NE.0) IOPZCA = 0 * * *** Load top directory information; gets in PAT1CT complete path name * CALL CDLDUP (PATHN, 1, IRC) IF (IRC.NE.0) GO TO 999 * * *** Set the current directory path name * PATHL = ' ' PATHY = PAT1CT PATHX = ' ' CALL RZCDIR (PATHY, ' ') NKEYCK = IQUEST(7) NWKYCK = IQUEST(8) LCDRCD = IQUEST(11) IKDRCD = IQUEST(13) 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 (ICMPCD.EQ.0) THEN IOPYCA = 1 PACKCZ = .FALSE. ELSE IF (ICMPCD.EQ.2.AND.IOPZCA.NE.0) THEN PACKCZ = .TRUE. PRECCZ = DELTCD ELSE PACKCZ = .FALSE. ENDIF IF (IOPBCA.EQ.0) THEN LUFZCF = LUFZCD ELSE LUFZCF = LUBKCD ENDIF * * *** Check the number of keys * IF (NWDIM.LT.NWKYCK) THEN IRC = 61 IQUEST(11) = NWKYCK IQUEST(12) = NWDIM #if defined(CERNLIB__DEBUG) IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDENTB : Too man'// + 'y keys '',I6,'' maximum permitted '',I6)', IQUEST(11), 2) #endif GO TO 999 ENDIF #if (defined(CERNLIB_UNIX)||defined(CERNLIB_IBMVM)||defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER)) * * *** Setup the server * IF (IOPPCD.NE.0) THEN #endif #if (defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER))&&(!defined(CERNLIB__P3CHILD))&&(defined(CERNLIB__ONLINE)) LUFZCF = LUFMCD #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) IF (IRC.NE.0) GO TO 999 #endif #if defined(CERNLIB__P3CHILD) LUFZCF = LODBP3 #endif #if (defined(CERNLIB_UNIX)||defined(CERNLIB_IBMVM)||defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER)) ENDIF #endif * * *** Get the IO descriptor for the header * IF (LUFZCF.GT.0) THEN NDOPC = LENOCC (CHOPT) IF (INDEX (CHOPT, 'H') .EQ. 0) THEN CHOP0 = 'H'//CHOPT NDOPC = NDOPC + 1 ELSE CHOP0 = CHOPT ENDIF NDOP = (NDOPC + 3) / 4 NLEV = 1 NCUR = 5 IFORO = 2 CHCUR(NLEV) = CFORM(IFORO) IF (PACKCZ.AND.IOPUCA.EQ.0) THEN NLCUR(NLEV) = 4 IFORO = 3 NCUR = 1 NLEV = NLEV + 1 CHCUR(NLEV) = CFORM(IFORO) CALL UCOPY (PRECCZ, IHEDCF(MPRECF), 1) ELSE IHEDCF(MPRECF) = IPRECD ENDIF DO 25 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, '(/,'' CDENTB : '// + 'Cannot get IO descriptor '//PATHY//''')', IARGCD, 0) #endif GO TO 999 ENDIF NLEV = NLEV + 1 CHCUR(NLEV) = CFORM(IFORM) NCUR = 1 IFORO = IFORM ENDIF 25 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 26 I = 1, NLEV CALL UTWRIT (CHFOR(II:II+1), '(I2)', NLCUR(I)) II = II + 2 CHFOR(II:II) = CHCUR(I) II = II + 2 26 CONTINUE #endif II = 4 *NLEV CHFOR = CHFOR(1:II)//' -H' CALL MZIOCH (IOFMCF, NWFMCF, CHFOR(1:II+3)) * * ** Partially fill up the header * NCHR = LENOCC (PATHY) NWDP = (NCHR + 3) / 4 NWDH = NWDP + NDOP + NWKYCK + 5 IHEDCF(MACTCF) = 1 IHEDCF(MNKYCF) = NWKYCK IHEDCF(MOPTCF) = NDOP IHEDCF(MPRECF) = NWDP IF (NDOP.GT.0) + CALL UCTOH (CHOP0, IHEDCF(NWKYCK+MPRECF+1), 4, 4*NDOP) CALL UCTOH (PATHY, IHEDCF(NWKYCK+NDOP+MPRECF+1), 4, 4*NWDP) ENDIF * * *** Take necessary action for partitioned and nonpartiitined datasets * IF (IOPTP.EQ.0) THEN KOBJ = 0 ELSE 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) MXKP = KYP1CK(MXKPCD) NWKYS = NWKYCK CHFOR = ' ' DO 30 I = 1, NWKYS IF (I.EQ.1) THEN CHFOR = CFORM(IOTYCK(I)) ELSE CHFOR = CHFOR(1:I-1)//CFORM(IOTYCK(I)) ENDIF 30 CONTINUE * CALL CDPATH (PATHX, NKEYCK) CALL RZCDIR (PATHX, ' ') 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 IF (IOPHCA.EQ.0.OR.KEY(IDHINS,1).LE.0) THEN KEY7CK = 0 ELSE KEY7CK = KEY(IDHINS,1) ENDIF IF (ICMPCD.EQ.2) THEN CHOP0 = 'ZP' ELSE IF (ICMPCD.NE.0) THEN CHOP0 = 'CP' ELSE CHOP0 = 'P ' ENDIF CALL CDMKDI (PATHY, NWKYS, CHFOR, CTAGCK, MXKP, IPRECD, + DELTCD, CHOP0, 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 (PATHX, NKEYCK) CALL RZCDIR (PATHX, ' ') IF (IQUEST(1).NE.0) GO TO 991 NKEYCK = IQUEST(7) LCDRCD = IQUEST(11) IKDRCD = IQUEST(13) ENDIF CALL UCOPY (KYP1CK, KYP2CK, NWKYCK) * ENDIF * * *** Get the Serial number of the last object inserted * LOBJ = KOBJ IF (NKEYCK.GT.0) THEN ISTP = NWKYCK + 1 DO 35 IK = 1, NKEYCK IP = KOFSCD + LCDRCD + IKDRCD + (IK-1)*ISTP + IDHKSN IF (IQ(IP).GT.LOBJ) LOBJ = IQ(IP) 35 CONTINUE ENDIF NINS = NKEYCK * * *** Lock the directory if necessary * IF (IOPPCD.EQ.0.AND.IOPSCD.NE.0) THEN CALL RZCDIR (PATHY, ' ') NKEYCK = IQUEST(7) LCDRCD = IQUEST(11) IKDRCD = IQUEST(13) CALL RZLOCK ('CDENTB') PATHL = PATHY IF (IOPTP.NE.0) THEN CALL RZCDIR (PATHX, ' ') NKEYCK = IQUEST(7) LCDRCD = IQUEST(11) IKDRCD = IQUEST(13) ENDIF ENDIF * * *** Loop over all the objects * DO 50 IOBJ = 1, NOBJ LOBJ = LOBJ + 1 NINS = NINS + 1 * IDB = ICDTYP (LSUP(IOBJ)) IF (IDB.EQ.2.OR.IDB.EQ.3) THEN IOPTR = 0 ELSE IOPTR = 1 ENDIF * IF (IOPYCA.NE.0 .OR. IOPTR.NE.0 .OR. IOPTCA.NE.0) THEN IF (IOPTCA.NE.0) THEN CHOP = 'S' ELSE IF (IOPYCA.NE.0) THEN CHOP = 'L' ELSE CHOP = ' ' ENDIF ELSE CHOP = 'S' ENDIF * * ** Fill up Key vectors 1,2,6,7 * KEY(IDHKSN,IOBJ) = LOBJ KEY(IDHPTR,IOBJ) = 0 KEY(IDHFLG,IOBJ) = MSBIT0 (KEY(IDHFLG,IOBJ), JRZUCD) KEY(IDHFLG,IOBJ) = MSBIT0 (KEY(IDHFLG,IOBJ), JPRTCD) KEY(IDHFLG,IOBJ) = MSBIT0 (KEY(IDHFLG,IOBJ), JASFCD) KEY(IDHFLG,IOBJ) = MSBIT0 (KEY(IDHFLG,IOBJ), JIGNCD) IF (IOPHCA.EQ.0.OR.KEY(IDHINS,IOBJ).LE.0) THEN CALL DATIME (IDATE, ITIME) CALL CDPKTM (IDATE, ITIME, IDATM, IRC) KEY(IDHINS,IOBJ) = IDATM ENDIF #if (defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER))&&(!defined(CERNLIB__P3CHILD))&&(defined(CERNLIB__ONLINE)) * IF (IOPPCD.NE.0) THEN CALL CDWLOK (IRC) IF (IRC.NE.0) GO TO 999 ENDIF #endif * * ** Write the sequential output if needed * IF (LUFZCF.GT.0) THEN CALL UCOPY (KEY(1,IOBJ), IHEDCF(MPRECF+1), NWKYCK) #if (defined(CERNLIB_UNIX)||defined(CERNLIB_IBMVM)||defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER)) IF (IOPPCD.NE.0) IHEDCF(MPRECF+IDHKSN) = 0 #endif #if defined(CERNLIB__P3CHILD) RNDBP3 = 'CDENTB ' NWDBP3 = 2 CALL UCTOH ('JOURNAL ', IWDBP3, 4, 8) CALL CDCHLD IRC = IQDBP3 IF (IRC.NE.0) GO TO 997 #endif CALL FZOUT (LUFZCF, IUDIV, LSUP(IOBJ), 1, CHOP, IOFMCF, + NWDH, IHEDCF) IF (IQUEST(1).NE.0) THEN IRC = 77 IQUEST(11) = IOBJ IQUEST(12) = NOBJ #if defined(CERNLIB__DEBUG) IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDENTB : Err'// + 'or in FZOUT while writing Data for '',2I12)', IQUEST(11),2) #endif GO TO 997 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 50 ENDIF #endif #if !defined(CERNLIB__P3CHILD) * IF (IOPYCA.NE.0 .OR. IOPTR.NE.0 .OR. IOPTCA.NE.0) THEN * * ** RZ mode output * KEY(IDHFLG,IOBJ) = MSBIT1 (KEY(IDHFLG,IOBJ), JRZUCD) IF (IOPTCA.NE.0) + KEY(IDHFLG,IOBJ) = MSBIT1 (KEY(IDHFLG,IOBJ), JASFCD) * #endif #if (defined(CERNLIB__DEBUG))&&(!defined(CERNLIB__P3CHILD)) IF (IDEBCD.GT.2) CALL RZLDIR (' ', ' ') #endif #if !defined(CERNLIB__P3CHILD) CALL RZOUT (IUDIV, LSUP(IOBJ), KEY(1,IOBJ), ICYCLE, CHOP) * ELSE * * ** Copy data to DB internal store * * ** 0 Data word : do not pack * IF (IQ(KOFUCD+LSUP(IOBJ)-1).EQ.0) THEN IRSET = 1 IOPPS = IOPPCA IOPZS = IOPZCA IOPPCA = 0 IOPZCA = 0 ELSE IRSET = 0 ENDIF CALL CDFRUS (LSUP(IOBJ), LSTRCL(1), IPRECD, IRC) IF (IRC.NE.0) THEN IF (IRSET.NE.0) THEN IOPPCA = IOPPS IOPZCA = IOPZS ENDIF GO TO 997 ENDIF * * ** Compress the data if requested * IF (IOPPCA.EQ.0.AND.IOPZCA.EQ.0) THEN LREFCL(1) = LSTRCL(1) IF (IRSET.NE.0) THEN IOPPCA = IOPPS IOPZCA = IOPZS ENDIF ELSE NOLD = NKEYCK NKEYCK = NINS - 1 CALL CDCOMP (LSTRCL(1), LREFCL(1), KEY(1,IOBJ), IRC) NKEYCK = NOLD ENDIF IF (IRC.NE.0) GO TO 997 * * ** Drop the uncompressed data * IF (LREFCL(1).NE.LSTRCL(1)) CALL MZDROP (IDISCD,LSTRCL(1),'L') * * ** Write on to disk * #endif #if (defined(CERNLIB__DEBUG))&&(!defined(CERNLIB__P3CHILD)) IF (IDEBCD.GT.2) CALL RZLDIR (' ', ' ') #endif #if !defined(CERNLIB__P3CHILD) CALL RZOUT (IDISCD, LREFCL(1), KEY(1,IOBJ), ICYCLE, 'S') IRC = IQUEST(1) CALL MZDROP (IDISCD, LREFCL(1), 'L') IQUEST(1) = IRC IF (IRC.EQ.77) GO TO 997 * ENDIF * IKDRCD = IQ(KOFSCD+LCDRCD+KLKDCD) NKEYCK = IQ(KOFSCD+LCDRCD+KNKDCD) IF (IOPTP.NE.0) THEN CALL CDPVAL (KEY(1,IOBJ)) ENDIF IF (IQUEST(1).NE.0) GO TO 993 #endif #if (defined(CERNLIB__DEBUG))&&(!defined(CERNLIB__P3CHILD)) IF (IDEBCD.GT.1) THEN CALL UCOPY (KEY(1,IOBJ), KEYNCK, NWKYCK) IARGCD(1) = IDATE IARGCD(2) = ITIME CALL CDPRNT (LPRTCD, '(/,'' CDENTB : Data was inserted into'// + ' '//PATHY//''',/,10X,''on the '',I8,'' at '',I6,'' '// + 'with Key-Vector '')', IARGCD, 2) CALL CDKEYT CALL CDPRKY (NWKYCK, KEYNCK, IOTYCK, IRC) ENDIF #endif #if !defined(CERNLIB__P3CHILD) IF (IOPTP.NE.0) THEN IF (NINS.GE.MXKP.AND.IOBJ.LT.NOBJ) THEN CALL RZCDIR (PATHY, ' ') IF (IQUEST(1).NE.0) GO TO 991 LCDRCD = IQUEST(11) IKDRCD = IQUEST(13) NKEYCK = IQUEST(7) * * ** Rename Keys 3 and 4 of the latest subdirectory * CALL RZRENK (KYP1CK, KYP2CK) IF (IQUEST(1).NE.0) THEN IRC = 74 #endif #if (defined(CERNLIB__DEBUG))&&(!defined(CERNLIB__P3CHILD)) IF (IDEBCD.GT.0) THEN CALL UCOPY (KYP1CK, IARGCD(1), NSYSCK) CALL UCOPY (KYP2CK, IARGCD(NSYSCK+1), NSYSCK) CALL CDPRNT (LPRTCD, '(/,'' CDENTB : Error in RZREN'// + 'K while writing data for '//PATHY//''',/(10X,'// + '7I12))', IARGCD, 2*NSYSCK) ENDIF #endif #if !defined(CERNLIB__P3CHILD) GO TO 998 ENDIF * * ** Make a different subdirectory if there are too many keys * IF (IOPHCA.EQ.0.OR.KEY(IDHINS,IOBJ+1).LE.0) THEN KEY7CK = 0 ELSE KEY7CK = KEY(IDHINS,IOBJ+1) ENDIF IF (ICMPCD.EQ.2) THEN CHOP0 = 'ZP' ELSE IF (ICMPCD.NE.0) THEN CHOP0 = 'CP' ELSE CHOP0 = 'P ' ENDIF CALL CDMKDI (PATHY, NWKYS, CHFOR, CTAGCK, MXKP, IPRECD, + DELTCD, CHOP0, IRC) IF (IRC.NE.0) GO TO 998 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) CALL CDPATH (PATHX, NKEYCK) CALL RZCDIR (PATHX, ' ') IF (IQUEST(1).NE.0) GO TO 991 NKEYCK = IQUEST(7) LCDRCD = IQUEST(11) IKDRCD = IQUEST(13) NINS = 0 CALL UCOPY (KYP1CK, KYP2CK, NWKYCK) ENDIF ENDIF #endif 50 CONTINUE GO TO 997 * * *** Error messages * 991 IRC = 71 #if defined(CERNLIB__DEBUG) IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDENTB : Illegal '// + 'Path Name '//PATHY//PATHX(1:8)//''')', IARGCD, 0) #endif GO TO 998 #if !defined(CERNLIB__P3CHILD) * 993 IRC = 73 #endif #if (defined(CERNLIB__DEBUG))&&(!defined(CERNLIB__P3CHILD)) IF (IDEBCD.GT.0) CALL CDPRNT (LPRTCD, '(/,'' CDENTB : Error in '// + 'RZOUT while writing Data for '//PATHY//PATHX(1:8)//''')', + IARGCD, 0) #endif * 997 CONTINUE #if (defined(CERNLIB_UNIX)||defined(CERNLIB_IBMVM)||defined(CERNLIB_VAX))&&(defined(CERNLIB__SERVER)) IF (IOPPCD.NE.0) GO TO 999 #endif #if !defined(CERNLIB__P3CHILD) IF (IOPTP.NE.0) THEN IF (NINS.GT.0) THEN CALL RZCDIR (PATHY, ' ') IF (IQUEST(1).NE.0) THEN IF (IRC.EQ.0) GO TO 991 ELSE LCDRCD = IQUEST(11) IKDRCD = IQUEST(13) NKEYCK = IQUEST(7) * * ** Rename Keys 3 and 4 of the latest subdirectory * IF (IRC.EQ.0) THEN CALL RZRENK (KYP1CK, KYP2CK) IF (IQUEST(1).NE.0) THEN IRC = 74 #endif #if (defined(CERNLIB__DEBUG))&&(!defined(CERNLIB__P3CHILD)) IF (IDEBCD.GT.0) THEN CALL UCOPY (KYP1CK, IARGCD(1), NSYSCK) CALL UCOPY (KYP2CK, IARGCD(NSYSCK+1), NSYSCK) CALL CDPRNT (LPRTCD, '(/,'' CDENTB : Error in RZREN'// + 'K while writing data for '//PATHY//''',/(10X,'// + '7I12))', IARGCD, 2*NSYSCK) ENDIF #endif #if !defined(CERNLIB__P3CHILD) ENDIF ENDIF ENDIF ENDIF ENDIF * * ** Free the locked directory if any * #endif 998 CONTINUE #if !defined(CERNLIB__P3CHILD) IF (PATHL.NE.' ') THEN CALL RZCDIR (PATHL, ' ') NKEYCK = IQUEST(7) LCDRCD = IQUEST(11) IKDRCD = IQUEST(13) CALL RZFREE ('CDENTB') ENDIF #endif #if !defined(CERNLIB_IBM)||!defined(CERNLIB__P3CHILD) * 2001 FORMAT (20(I2,A1,1X)) #endif * END CDENTB 999 END