MINICERN/packlib/zebra/rz/rzfrfz.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/24 17:26:52  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 RZFRFZ(LUNFZ,CHOPT)
  15 *
  16 ************************************************************************
  17 *
  18 *        To read the sequential file LUNFZ into the CWD
  19 *     NB. A call to FZOPEN must preceede this call
  20 * Input:
  21 *   LUNFZ   Logical unit number of the FZ sequential access file
  22 *   CHOPT   default, read all cycles for path CHPATH
  23 *           'H' read only the highest cycle
  24 *
  25 * Called by <USER>
  26 *
  27 *  Author  : R.Brun DD/US/PD
  28 *  Written : 14.05.86
  29 *  Last mod: 21.10.91
  30 *
  31 ************************************************************************
  32 #include "zebra/zbcdch.inc"
  33 #include "zebra/rzcl.inc"
  34 #include "zebra/rzch.inc"
  35 #include "zebra/rzk.inc"
  36 #include "zebra/rzckey.inc"
  37 #include "zebra/rzclun.inc"
  38       CHARACTER*(*) CHOPT
  39       CHARACTER*128 CHFORM
  40       CHARACTER*1  BSLASH
  41       DIMENSION IHDIR(4),ICDIR(KNMAX)
  42       EQUIVALENCE (ICDIR(1),KEY(1))
  43       LOGICAL RZSAME
  44 *
  45 *-----------------------------------------------------------------------
  46 *
  47       BSLASH=CQALLC(61:61)
  48       IQUEST(1)=0
  49       IF(LQRS.EQ.0)GO TO 99
  50 *
  51 *           Check permission
  52 *
  53       IFLAG=0
  54       CALL RZMODS('RZFRFZ',IFLAG)
  55       IF(IFLAG.NE.0)GO TO 99
  56       CALL UOPTC(CHOPT,'H',IOPTH)
  57 *
  58 *           Save CWD name
  59 *
  60 *
  61       CALL RZCDIR(CHWOLD,'R')
  62       ITIME=0
  63 *
  64 *           Read general header and find next RZ construct
  65 *
  66   10  NH=KNSIZE
  67       CALL FZIN(LUNFZ,JQPDVS,0,0,'S',NH,IHEAD)
  68       IF(IQUEST(1).NE.0)GO TO 99
  69       IF(NH.NE.2)GO TO 10
  70       IF(IHEAD(1).NE.12345)GO TO 10
  71       NLPI0=IHEAD(2)
  72       NLPI=NLPI0
  73 *
  74 *           Read next directory
  75 *
  76   20  CONTINUE
  77       ITIME=ITIME+1
  78       NH=KNSIZE
  79       CALL FZIN(LUNFZ,JQPDVS,0,0,'S',NH,IHEAD)
  80       IF(IQUEST(1).NE.0)GO TO 90
  81       IF(NH.EQ.1.AND.IHEAD(1).EQ.99.AND.ITIME.NE.0)GO TO 90
  82       IF(NH.NE.KNSIZE)GO TO 20
  83       IF(IHEAD(1).NE.1)GO TO 20
  84       IF(IHEAD(2).EQ.NLPI0)GO TO 70
  85 *
  86 *          Go back levels
  87 *
  88       IF(IHEAD(2).LE.NLPI)THEN
  89          CALL MZDROP(JQPDVS,LCDIR,' ')
  90          CHL=BSLASH
  91          ICHL=1
  92          DO 30 I=NLPI-1,IHEAD(2),-1
  93             CHFORM=CHL(1:ICHL)//BSLASH
  94             CHL=CHFORM
  95             ICHL=ICHL+1
  96   30     CONTINUE
  97          CALL RZCDIR(CHL,' ')
  98       ENDIF
  99 *
 100 *           New subdirectory. Check if directory does not exist already
 101 *
 102       LS=IQ(KQSP+LCDIR+KLS)
 103       NSDIR=IQ(KQSP+LCDIR+KNSD)
 104       CALL ZITOH(ICDIR,IHDIR,4)
 105       CALL UHTOC(IHDIR,4,CHL,16)
 106       NWKEY=ICDIR(KNWKEY)
 107       KTAGS=KKDES+(NWKEY-1)/10+1
 108       DO 40 I=1,NSDIR
 109          IF(RZSAME(ICDIR,IQ(KQSP+LCDIR+LS+7*(I-1)),4))GO TO 60
 110   40  CONTINUE
 111 *
 112 *           Create subdirectory
 113 *
 114       CALL RZMDIR(CHL,NWKEY,'?',' ')
 115       IF(IQUEST(1).NE.0)GO TO 90
 116 *
 117 *           Set CWD to new branch
 118 *
 119   60  CALL RZCDIR(CHL,' ')
 120 *
 121 *         Is directory big enough ?
 122 *
 123       IF(IQ(KQSP+LCDIR-1).LT.ICDIR(KLE))THEN
 124          NM=ICDIR(KLE)-IQ(KQSP+LCDIR-1)
 125          CALL RZEXPD('RZFRFZ',NM)
 126          IF(IQUEST(1).NE.0) GO TO 90
 127       ENDIF
 128       CALL UCOPY(ICDIR(KKDES),IQ(KQSP+LCDIR+KKDES),2*NWKEY+KTAGS-KKDES)
 129       CALL UCOPY(ICDIR(KDATEC),IQ(KQSP+LCDIR+KDATEC),2)
 130 *
 131   70  NLPI=IHEAD(2)
 132 *
 133 *           Copy keys from sequential file to CWD
 134 *
 135       CALL SBIT1(IQ(KQSP+LTOP),2)
 136       CALL RZFRF1(LUNFZ,IOPTH)
 137       IF(IQUEST(1).EQ.0) GO TO 20
 138 *
 139 *           Set CWD to original value
 140 *
 141   90  ISAVE = 2
 142       IQ1=IQUEST(1)
 143       CALL RZSAVE
 144       CALL RZCDIR(CHWOLD,' ')
 145       IQUEST(1)=IQ1
 146 *
 147   99  RETURN
 148       END