MINICERN/packlib/zebra/rz/rzcop1.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/24 17:26:43  mclareni
   6 * Extend the include file cleanup to dzebra, rz and tq, and also add
   7 * dependencies in some cases.
   8 *
   9 * Revision 1.1.1.1  1996/03/06 10:47:23  mclareni
  10 * Zebra
  11 *
  12 *
  13 #include "zebra/pilot.h"
  14       SUBROUTINE RZCOP1(LUNOLD,LROLD,KEY,IOLD)
  15 *
  16 ************************************************************************
  17 *
  18 *          Copy one (KEY,CYCLE) from LFROM to the CWD
  19 * Input:
  20 *   LUNOLD  Logical unit number of the file from which the copy is made
  21 *   LROLD   Record size of LUNOLD
  22 *   KEY     Identification (array) of the key to created in the CWD
  23 *   IOLD    Array of 4 words describing the cycle which is copied
  24 *
  25 * Called by RZCOPY
  26 *
  27 *  Author  : R.Brun DD/US/PD
  28 *  Written : 07.05.86
  29 *  Last mod: 01.09.92 Dave Morrison (MIT) handle append mode bit
  30 *          : 04.03.94 S.Banerjee (Change in cycle structure)
  31 *          : 23.03.95 J.Shiers - key # in cycles block is KEY(1)
  32 *
  33 ************************************************************************
  34 #include "zebra/rzcl.inc"
  35 #include "zebra/rzclun.inc"
  36 #include "zebra/rzk.inc"
  37 #include "zebra/rzcycle.inc"
  38       DIMENSION KEY(*),IOLD(4)
  39 *
  40 *-----------------------------------------------------------------------
  41 *
  42 #include "zebra/q_jbit.inc"
  43 #include "zebra/q_jbyt.inc"
  44
  45 *
  46 *         Get last record written in that directory
  47 *         Create buffer bank
  48 *
  49       IF (KVSCYC.EQ.0) THEN
  50          IR1OLD = JBYT(IOLD(KFRCYC),17,16)
  51          IP1OLD = JBYT(IOLD(KORCYC), 1,16)
  52          IR2OLD = JBYT(IOLD(KSRCYC),17,16)
  53          NDATA  = JBYT(IOLD(KNWCYC), 1,20)
  54          IFORM  = JBYT(IOLD(KFLCYC), 1, 3)
  55       ELSE
  56          IR1OLD = IOLD(KFRCYC)
  57          IP1OLD = JBYT(IOLD(KORCYC), 1,20)
  58          IR2OLD = IOLD(KSRCYC)
  59          NDATA  = IOLD(KNWCYC)
  60          IFORM  = JBYT(IOLD(KFLCYC), 1, 3)
  61       ENDIF
  62       LROUT  = LQ(KQSP+LTOP-6)
  63       IROUT  = IQ(KQSP+LTOP+KIROUT)
  64       IRLOUT = IQ(KQSP+LCDIR+KRLOUT)
  65       IP1    = IQ(KQSP+LCDIR+KIP1)
  66       IF(LROUT.EQ.0)THEN
  67          CALL MZBOOK(JQPDVS,LROUT,LTOP,-6,'RZOU',0,0,LREC+1,2,-1)
  68          IQ(KQSP+LROUT-5)=LUN
  69          IROUT=0
  70          IP1=1
  71       ENDIF
  72       IF(IROUT.NE.IRLOUT.AND.IRLOUT.NE.0)THEN
  73          CALL RZIODO(LUN,LREC,IRLOUT,IQ(KQSP+LROUT+1),1)
  74          IF(IQUEST(1).NE.0)GO TO 999
  75 #if defined(CERNLIB_QMVAX)
  76          IF(IRELAT.NE.0)UNLOCK(UNIT=LUN)
  77 #endif
  78          IROUT=IRLOUT
  79          IQ(KQSP+LTOP+KIROUT)=IROUT
  80          IP1=IQ(KQSP+LCDIR+KIP1)
  81          IF(IQ(KQSP+LTOP+KIRIN).EQ.IROUT)IQ(KQSP+LTOP+KIRIN) = 0
  82       ENDIF
  83 *
  84 *         Is directory big enough to accomodate new cycle ?
  85 *
  86       IF(IQ(KQSP+LCDIR+KNFREE).LT.IQ(KQSP+LCDIR+KNWKEY)+4*KLCYCL+1)THEN
  87          CALL RZEXPD('RZCOPY',10*(IQ(KQSP+LCDIR+KNWKEY)+KLCYCL+1))
  88          IF(IQUEST(1).NE.0) GO TO 999
  89       ENDIF
  90       LK = IQ(KQSP+LCDIR+KLK)
  91       LF = IQ(KQSP+LCDIR+KLF)
  92       LC = IQ(KQSP+LCDIR+KLC)
  93       NWFREE=IQ(KQSP+LCDIR+KNFREE)
  94 *
  95 *         Compute how many records
  96 *         are necessary to write data structure.
  97 *
  98       NLEFT=LREC-IP1+1
  99       IF(NDATA.LE.NLEFT)THEN
 100          N1=NDATA
 101          NR=0
 102       ELSE
 103          N1=NLEFT
 104          NR=(NDATA-NLEFT-1)/LREC + 1
 105       ENDIF
 106       IF(IRLOUT.EQ.0)NR=NR+1
 107       IF(NR.GT.0)THEN
 108          CALL RZALLO('RZCOPY',NR,IALLOC)
 109          IF(IALLOC.EQ.0) GO TO 999
 110          IF(IRLOUT.EQ.0)IRLOUT=IALLOC
 111       ENDIF
 112 *
 113 *         Search if KEY is already entered
 114 *
 115       NKEYS = IQ(KQSP+LCDIR+KNKEYS)
 116       NWKEY = IQ(KQSP+LCDIR+KNWKEY)
 117       IQUEST(7)=NKEYS
 118       IQUEST(8)=NWKEY
 119 *
 120       IF(NKEYS.GT.0)THEN
 121          DO 20 I=1,NKEYS
 122             LKC=LK+(NWKEY+1)*(I-1)
 123             DO 10 K=1,NWKEY
 124                IF(IQ(KQSP+LCDIR+LKC+K).NE.KEY(K))GO TO 20
 125   10        CONTINUE
 126             LCOLD  = IQ(KQSP+LCDIR+LKC)
 127             IF (KVSCYC.NE.0) THEN
 128 *              IF (IQ(KQSP+LCDIR+LCOLD+KKYCYC).NE.I) THEN
 129                IF (IQ(KQSP+LCDIR+LCOLD+KKYCYC).NE.
 130      +             IQ(KQSP+LCDIR+LKC+1)) THEN
 131                   IQUEST(1) = 11
 132                   GO TO 999
 133                ENDIF
 134             ENDIF
 135             ICOLD  = JBYT(IQ(KQSP+LCDIR+LCOLD+KCNCYC),21,12)
 136             ICYCLE = ICOLD+1
 137 *           IKYV   = I
 138             IKYV   = IQ(KQSP+LCDIR+LKC+1)
 139             GO TO 50
 140   20     CONTINUE
 141       ENDIF
 142 *
 143 *         New KEY, append to the list
 144 *
 145       NWFREE=NWFREE-NWKEY-1
 146       IQ(KQSP+LCDIR+KNKEYS)=IQ(KQSP+LCDIR+KNKEYS)+1
 147       LCOLD=0
 148       LKC=LF
 149       LF=LF+NWKEY+1
 150       DO 30 I=1,NWKEY
 151          IQ(KQSP+LCDIR+LKC+I)=KEY(I)
 152   30  CONTINUE
 153       ICYCLE = 1
 154 *     IKYV   = IQ(KQSP+LCDIR+KNKEYS)
 155       IKYV   = IQ(KQSP+LCDIR+LKC+1)
 156 *
 157 *         Create a new cycle
 158 *
 159   50  LKCSV = IQ(KQSP+LCDIR+LKC)
 160       LC    = LC-KLCYCL
 161       NWFREE= NWFREE-KLCYCL
 162       IQ(KQSP+LCDIR+LKC) = LC
 163       IQ(KQSP+LCDIR+LC+KPPCYC) = LCOLD
 164       IQ(KQSP+LCDIR+LC+KFLCYC)=0
 165       CALL RZDATE (IQ(KQSP+LCDIR+LC+KFLCYC),IDATE,ITIME,2)
 166 c
 167 c     DPM: Added this to handle append mode.
 168 c
 169       IBIT4 = JBIT(IOLD(KFLCYC),4)
 170       IF(IBIT4.EQ.1)CALL SBIT1(IQ(KQSP+LCDIR+LC+KFLCYC),4)
 171 c
 172 c     DPM: End of changes.
 173 c
 174       CALL SBYT (IFORM,IQ(KQSP+LCDIR+LC+KFLCYC),1,3)
 175       IQ(KQSP+LCDIR+LC+KORCYC) = IP1
 176       IQ(KQSP+LCDIR+LC+KNWCYC) = NDATA
 177       CALL SBYT(ICYCLE,IQ(KQSP+LCDIR+LC+KCNCYC),21,12)
 178       IF (KVSCYC.EQ.0) THEN
 179          IF(N1.LT.NDATA)CALL SBYT(IALLOC,IQ(KQSP+LCDIR+LC+KSRCYC),17,16)
 180          CALL SBYT(IRLOUT,IQ(KQSP+LCDIR+LC+KFRCYC),17,16)
 181       ELSE
 182          IF (N1.LT.NDATA) THEN
 183             IQ(KQSP+LCDIR+LC+KSRCYC) = IALLOC
 184          ELSE
 185             IQ(KQSP+LCDIR+LC+KSRCYC) = 0
 186          ENDIF
 187          IQ(KQSP+LCDIR+LC+KFRCYC) = IRLOUT
 188          IQ(KQSP+LCDIR+LC+KKYCYC) = IKYV
 189       ENDIF
 190       IQUEST(3)=IRLOUT
 191       IQUEST(4)=IP1
 192       IQUEST(5)=0
 193       IQUEST(6)=ICYCLE
 194       IQUEST(11)=NDATA
 195 *
 196 *          Copy records
 197 *           Start filling current block
 198 *
 199       IF(LRIN.EQ.0)THEN
 200          CALL MZBOOK(JQPDVS,LRIN,LTOP,-7,'RZIN',0,0,LROLD+1,2,-1)
 201          IQ(KQSP+LRIN-5)=IQ(KQSP+LTOP-5)
 202       ELSE
 203          NOLD=IQ(KQSP+LRIN-1)
 204          IF(NOLD.LT.LROLD)THEN
 205             CALL MZPUSH(JQPDVS,LRIN,0,LROLD-NOLD,'I')
 206          ENDIF
 207       ENDIF
 208       CALL RZIODO(LUNOLD,LROLD,IR1OLD,IQ(KQSP+LRIN+1),1)
 209       IF(IQUEST(1).NE.0) GO TO 900
 210       NWC=N1
 211       IRN=IR2OLD-1
 212   55  IF(NWC.GT.LROLD-IP1OLD+1)THEN
 213          NWC=LROLD-IP1OLD+1
 214          CALL UCOPY(IQ(KQSP+LRIN+IP1OLD),IQ(KQSP+LROUT+IP1),NWC)
 215          IP1OLD=1
 216          IF(NWC.LT.N1)THEN
 217             IRN=IRN+1
 218             CALL RZIODO(LUNOLD,LROLD,IRN,IQ(KQSP+LRIN+1),1)
 219             IF(IQUEST(1).NE.0) GO TO 900
 220             NWC=N1-NWC
 221             GO TO 55
 222          ENDIF
 223       ELSE
 224          CALL UCOPY(IQ(KQSP+LRIN+IP1OLD),IQ(KQSP+LROUT+IP1),NWC)
 225          IP1OLD=IP1OLD+NWC
 226       ENDIF
 227       IF(IP1.EQ.1)THEN
 228          IRLOUT=IALLOC
 229          IROUT=IRLOUT
 230       ENDIF
 231       IP1=IP1+N1
 232       IF(IP1.GT.LREC)THEN
 233          CALL RZIODO(LUN,LREC,IRLOUT,IQ(KQSP+LROUT+1),2)
 234          IF(IQUEST(1).NE.0) GO TO 900
 235          IF(IP1.GT.NDATA)IRLOUT=0
 236          IP1=1
 237       ENDIF
 238       IF(N1.LT.NDATA)THEN
 239          IQUEST(5)=IALLOC
 240          IQUEST(2)=NR+1
 241          DO 60 I=1,NR
 242             IP1=1
 243             NW=NDATA-N1
 244             IF(NW.GT.LREC)NW=LREC
 245             NWC=NW
 246   57        IF(NWC.GT.LROLD-IP1OLD+1)THEN
 247                NWC=LROLD-IP1OLD+1
 248                CALL UCOPY(IQ(KQSP+LRIN+IP1OLD),IQ(KQSP+LROUT+IP1),NWC)
 249                IP1OLD=1
 250                IF(NWC.LT.N1)THEN
 251                   IRN=IRN+1
 252                   CALL RZIODO(LUNOLD,LROLD,IRN,IQ(KQSP+LRIN+1),1)
 253                   IF(IQUEST(1).NE.0) GO TO 900
 254                   NWC=NW-NWC
 255                   GO TO 57
 256                ENDIF
 257             ELSE
 258                CALL UCOPY(IQ(KQSP+LRIN+IP1OLD),IQ(KQSP+LROUT+IP1),NWC)
 259                IP1OLD=IP1OLD+NWC
 260             ENDIF
 261             IF(NW.EQ.LREC)THEN
 262                CALL RZIODO(LUN,LREC,IROUT,IQ(KQSP+LROUT+1),2)
 263                IF(IQUEST(1).NE.0) GO TO 900
 264             ELSE
 265                IRLOUT=IALLOC+I-1
 266                IROUT=IRLOUT
 267             ENDIF
 268             IP1=IP1+NW
 269             N1=N1+NW
 270   60     CONTINUE
 271       ENDIF
 272 *
 273 *         Update internal pointers in the directory
 274 *
 275       IQ(KQSP+LTOP+KIROUT)=IROUT
 276       IQUEST(9)=IQ(KQSP+LCDIR+KQUOTA)-IQ(KQSP+LCDIR+KRUSED)
 277       IQ(KQSP+LCDIR+KRUSED)=IQ(KQSP+LCDIR+KRUSED)+NR
 278       NWUSED=IQ(KQSP+LCDIR+KWUSED)+NDATA
 279       IF(NWUSED.GT.1000000)THEN
 280          IQ(KQSP+LCDIR+KMEGA)=IQ(KQSP+LCDIR+KMEGA)+1
 281          IQ(KQSP+LCDIR+KWUSED)=NWUSED-1000000
 282       ELSE
 283          IQ(KQSP+LCDIR+KWUSED)=NWUSED
 284       ENDIF
 285       IQ(KQSP+LCDIR+KRLOUT)=IRLOUT
 286       IQ(KQSP+LCDIR+KIP1)=IP1
 287       IQ(KQSP+LCDIR+KNFREE)=NWFREE
 288       IQ(KQSP+LCDIR+KLF)=LF
 289       IQ(KQSP+LCDIR+KLC)=LC
 290 *
 291 *         Mark used records
 292 *
 293       IF(NR.GT.0)THEN
 294          CALL RZUSED(NR,IALLOC)
 295       ENDIF
 296       GO TO 999
 297 *         Reset internal pointers in case of I/O problem
 298 *
 299  900  IF(ICYCLE.EQ.1)THEN
 300         IQ(KQSP+LCDIR+KNKEYS)=IQ(KQSP+LCDIR+KNKEYS)-1
 301       ENDIF
 302       IQ(KQSP+LCDIR+LKC)=LKCSV
 303 *
 304  999  RETURN
 305       END