MINICERN/packlib/zebra/rz/rztof1.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/24 17:27:10  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:26  mclareni
  10 * Zebra
  11 *
  12 *
  13 #include "zebra/pilot.h"
  14       SUBROUTINE RZTOF1(LUNFZ,IOPTC)
  15 *
  16 ************************************************************************
  17 *
  18 *        Copy current directory to a sequential FZ file
  19 * Input:
  20 *   LUNFZ   Logical unit number of the FZ sequential access file
  21 *   IOPTC   0 save only the highest cycle to LUNFZ
  22 *           1 save all cycles
  23 *
  24 * Called by <RZTOFZ>
  25 *
  26 *  Author  : R.Brun DD/US/PD
  27 *  Written : 14.05.86
  28 *  Last mod: 04.10.90
  29 *          : 04.03.94 S.Banerjee (Change in cycle structure)
  30 *          : 23.03.95 J.Shiers - key # in cycles block is KEY(1)
  31 *
  32 ************************************************************************
  33 #include "zebra/rzcl.inc"
  34 #include "zebra/rzdir.inc"
  35 #include "zebra/rzk.inc"
  36 #include "zebra/rzckey.inc"
  37 #include "zebra/rzcycle.inc"
  38 *
  39 *-----------------------------------------------------------------------
  40 *
  41 #include "zebra/q_jbyt.inc"
  42 *
  43 *            Fill header for directory
  44 *
  45       NKEYS=IQ(KQSP+LCDIR+KNKEYS)
  46       NWKEY=IQ(KQSP+LCDIR+KNWKEY)
  47       LB   = IQ(KQSP+LTOP+KLB)
  48       LREC = IQ(KQSP+LTOP+LB+1)
  49       IDECK=0
  50       IF(NWKEY.EQ.2.AND.LREC.EQ.128)THEN
  51          KTAGS=KKDES+1
  52          CALL ZITOH(IQ(KQSP+LCDIR+KTAGS),KEY,2)
  53          CALL UCTOH('DECKNAME',KEY2,4,8)
  54          IF(KEY(1).EQ.KEY2(1).AND.KEY(2).EQ.KEY2(2))THEN
  55             IDECK=1
  56          ENDIF
  57       ENDIF
  58       NH   =NWKEY+3
  59       IHEAD(1)=1
  60       IHEAD(2)=NLPAT
  61       IHEAD(3)=0
  62       CALL UCOPY(IQ(KQSP+LCDIR+1),KEY,KNSIZE-3)
  63 *
  64 *            Write directory header
  65 *
  66       CALL FZOUT(LUNFZ,JQPDVS,0,1,'Z',1,KNSIZE,IHEAD)
  67       IF(IQUEST(1).NE.0)GO TO 99
  68 *
  69 *           Loop on all keys of level 0
  70 *
  71       IHEAD(1)=0
  72       DO 80 I=1,NKEYS
  73          LK=IQ(KQSP+LCDIR+KLK)
  74          LKC=LK+(NWKEY+1)*(I-1)
  75          DO 25 K=1,NWKEY
  76             KEY(K)=IQ(KQSP+LCDIR+LKC+K)
  77   25     CONTINUE
  78          LCYC  =IQ(KQSP+LCDIR+LKC)
  79          IF (KVSCYC.NE.0) THEN
  80 *           IF (IQ(KQSP+LCDIR+LCYC+KKYCYC).NE.I) THEN
  81             IF (IQ(KQSP+LCDIR+LCYC+KKYCYC).NE.IQ(KQSP+LCDIR+LKC+1)) THEN
  82                IQUEST(1) = 11
  83                GO TO 99
  84             ENDIF
  85          ENDIF
  86 *
  87 *               Store cycles in reverse order for 'C' option
  88 *
  89          IF(IOPTC.NE.0)THEN
  90             IF(LCORD.EQ.0)THEN
  91                CALL MZBOOK(JQPDVS,LCORD,LTOP,-4,'RZCO',0,0,50,2,-1)
  92             ENDIF
  93             IQ(KQSP+LCORD+1)=0
  94   30        NORD=IQ(KQSP+LCORD+1)+1
  95             IF (KVSCYC.EQ.0) THEN
  96                LCOLD = JBYT(IQ(KQSP+LCDIR+LCYC+KPPCYC), 1,16)
  97             ELSE
  98                LCOLD = IQ(KQSP+LCDIR+LCYC+KPPCYC)
  99             ENDIF
 100             IF(NORD.GT.IQ(KQSP+LCORD-1))THEN
 101                CALL MZPUSH(JQPDVS,LCORD,0,50,'I')
 102             ENDIF
 103             IQ(KQSP+LCORD+1)=NORD
 104             IQ(KQSP+LCORD+NORD+1)=LCYC
 105             IF(LCOLD.NE.0.AND.LCOLD.NE.LCYC)THEN
 106                LCYC=LCOLD
 107                GO TO 30
 108             ENDIF
 109             DO 40 IC=NORD,1,-1
 110                LCYC= IQ(KQSP+LCORD+IC+1)
 111                ICY = JBYT(IQ(KQSP+LCDIR+LCYC+KCNCYC),21,12)
 112                CALL RZIN(JQPDVS,LRZ0,-1,I,ICY,'S')
 113                IF(IQUEST(1).NE.0)GO TO 99
 114                LFROM=LQ(KQSP+LRZ0-1)
 115                IF(IDECK.NE.0)THEN
 116                   NDATA=IQ(KQSP+LFROM-1)
 117                   NT=NDATA/5 +40
 118                   CALL MZBOOK(JQPDVS,LTEMP,LFROM,0,'TEMP',0,0,NT,1,-1)
 119                   NTOT=0
 120                   NEW=1
 121   35              IF(NTOT.LT.NDATA)THEN
 122                      IF(NEW.GT.NT-1)THEN
 123                         CALL MZPUSH(JQPDVS,LTEMP,0,50,'I')
 124                         NT=NT+50
 125                      ENDIF
 126                      CALL RZLIND(IQ(KQSP+LFROM+1),NTOT,
 127      +                           IQ(KQSP+LTEMP+1),NEW)
 128                      NEW=NEW+1
 129                      GO TO 35
 130                   ENDIF
 131                ENDIF
 132                IHEAD(2)=IC
 133                IHEAD(3)=IQ(KQSP+LCDIR+LCYC+KFLCYC)
 134                IQUEST(1)=0
 135                CALL FZOUT(LUNFZ,JQPDVS,LFROM,1,'L',2,NH,IHEAD)
 136                IF(IQUEST(1).NE.0)GO TO 90
 137                CALL MZDROP(JQPDVS,LFROM,'L')
 138                LFROM=0
 139   40        CONTINUE
 140          ELSE
 141   50        ICY   =JBYT(IQ(KQSP+LCDIR+LCYC+KCNCYC),21,12)
 142             CALL RZIN(JQPDVS,LRZ0,-1,I,ICY,'S')
 143             IF(IQUEST(1).NE.0)GO TO 99
 144             LFROM=LQ(KQSP+LRZ0-1)
 145             IF(IDECK.NE.0)THEN
 146                NDATA=IQ(KQSP+LFROM-1)
 147                NT=NDATA/5 +40
 148                CALL MZBOOK(JQPDVS,LTEMP,LFROM,0,'TEMP',0,0,NT,1,-1)
 149                NTOT=0
 150                NEW=1
 151   55           IF(NTOT.LT.NDATA)THEN
 152                   IF(NEW.GT.NT-1)THEN
 153                      CALL MZPUSH(JQPDVS,LTEMP,0,50,'I')
 154                      NT=NT+50
 155                   ENDIF
 156                   CALL RZLIND(IQ(KQSP+LFROM+1),NTOT,
 157      +                        IQ(KQSP+LTEMP+1),NEW)
 158                   NEW=NEW+1
 159                   GO TO 55
 160                ENDIF
 161             ENDIF
 162             IHEAD(2)=1
 163             IHEAD(3)=IQ(KQSP+LCDIR+LCYC+KFLCYC)
 164             IQUEST(1)=0
 165             CALL FZOUT(LUNFZ,JQPDVS,LFROM,1,'L',2,NH,IHEAD)
 166             IF(IQUEST(1).NE.0)GO TO 90
 167             CALL MZDROP(JQPDVS,LFROM,'L')
 168             LFROM=0
 169          ENDIF
 170 *
 171   80  CONTINUE
 172 *
 173 *           Write directory trailer
 174 *
 175       CALL FZOUT(LUNFZ,JQPDVS,0,0,'Z',1,1,77)
 176 *
 177   90  IF(LFROM.GT.0)THEN
 178          IQ1=IQUEST(1)
 179          CALL MZDROP(JQPDVS,LFROM,'L')
 180          IQUEST(1)=IQ1
 181       ENDIF
 182 *
 183   99  RETURN
 184       END