MINICERN/packlib/zebra/rz/rzcdir.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/24 17:26:40  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 RZCDIR(CHPATH,CHOPT)
  15 *
  16 ************************************************************************
  17 *
  18 *      To set,read or print the Current Working Directory
  19 * Input:
  20 *   *CHPATH* Character  variable  specifying  the  pathname  of  the  CWD
  21 *            (default option).
  22 *            Unless several RZ files are open at the same time,  the path
  23 *            name can  be specified  either as a  path starting  with the
  24 *            character  '/',   in  which case  an  absolute  pathname  is
  25 *            intended for the given top directory.  When several RZ files
  26 *            are open,   an absolute  pathname must  start with  a double
  27 *            slash '//' and  the top directory.   When  the pathname does
  28 *            not start with a '/', the pathname is prefixed with the path
  29 *            of the CWD.
  30 *            CHPATH = ' ' means the CWD (useful with the 'U' option)
  31 *   CHOPT    Character variable specifying the option
  32 *            'R'   Read the CWD pathname into CHPATH
  33 *            'P'   Print the CWD
  34 *            ' '   Set the CWD
  35 *            'U'   The same  as the  default but  the time  stamp in  the
  36 *                  directory in memory is checked  against the one on the
  37 *                  file and if needed the  directory in memory is brought
  38 *                  up  to date. This option  should be  used when the user
  39 *                  expects that  directories can be  changed concurrently
  40 *                  by another user and he wants to use the latest version
  41 *            'Q'   quiet - do not print message if directory does not exist
  42 *            'K'   Keep current directory in memory. Do not drop
  43 * Output:
  44 *   *CHPATH* Character variable  containing the complete pathname  of the
  45 *            current working directory (with 'R' option only).
  46 *
  47 * Called by <USER>,RZINPA,RZLDIR
  48 *
  49 *  Author  : R.Brun DD/US/PD
  50 *  Written : 02.04.86
  51 *  Last mod: 09.06.93 JDS. Protection against no RZ files open
  52 *
  53 *  IQUEST(1) = 1 : RZIODO error
  54 *              2 : unknown directory
  55 *              3 : directory overwritten
  56 *              4 : no control bank - RZFILE/RZMAKE not called
  57 *              5 : no open files (RZEND called for all)
  58 *
  59 ************************************************************************
  60 #include "zebra/zunit.inc"
  61 #include "zebra/rzcl.inc"
  62 #include "zebra/rzdir.inc"
  63 #include "zebra/rzch.inc"
  64 #include "zebra/rzclun.inc"
  65 #include "zebra/rzk.inc"
  66       DIMENSION    IOPTV(5)
  67       EQUIVALENCE (IOPTR,IOPTV(1)), (IOPTP,IOPTV(2)), (IOPTU,IOPTV(3))
  68       EQUIVALENCE (IOPTK,IOPTV(4)), (IOPTQ,IOPTV(5))
  69       CHARACTER*(*) CHPATH,CHOPT
  70       CHARACTER*1   COPTQ
  71 *
  72 *-----------------------------------------------------------------------
  73 *
  74 #include "zebra/q_jbit.inc"
  75 #include "zebra/q_jbyt.inc"
  76
  77       IQUEST(1)=0
  78
  79       CALL UOPTC (CHOPT,'RPUKQ',IOPTV)
  80       IF(IOPTK.NE.0) IOPTU=0
  81       IF(IOPTR.NE.0) CHPATH = ' '
  82 *
  83 *     Check for RZ control bank (i.e. did we call RZFILE/MAKE yet)
  84 *
  85       IF(LQRS.EQ.0) THEN
  86          IQUEST(1) = 4
  87          GOTO 999
  88       ENDIF
  89 *
  90 *     Check that we have at least one RZ file still open
  91 *
  92       LRZ=LQRS
  93    10 IF(LRZ.EQ.0) GOTO 20
  94       IF(IQ(KQSP+LRZ-5).NE.0) GOTO 30
  95       LRZ=LQ(KQSP+LRZ)
  96       GO TO 10
  97    20 CONTINUE
  98       IQUEST(1) = 5
  99       GOTO 999
 100    30 CONTINUE
 101 *
 102 *             Read Working directory
 103 *
 104       IF(IOPTR.NE.0)THEN
 105          CALL RZPAFF(CHCDIR,NLCDIR,CHPATH)
 106          GO TO 999
 107       ENDIF
 108 *
 109 *             Print Working directory
 110 *
 111       IF(IOPTP.NE.0)THEN
 112          CALL RZPAFF(CHCDIR,NLCDIR,CHL)
 113          WRITE(IQPRNT,10000)CHL(1:LENOCC(CHL))
 114 10000 FORMAT(' Current Working Directory = ',A)
 115          GO TO 999
 116       ENDIF
 117 *
 118 *             Set Working directory
 119 *             Mark old working directory to be dropped
 120 *             Write current directory if modified
 121 *
 122       COPTQ = ' '
 123       IF(IOPTQ.NE.0) COPTQ = 'Q'
 124       IF(LCDIR.NE.0.AND.ISAVE.NE.0.AND.IOPTK.EQ.0)THEN
 125          LBANK=LCDIR
 126    40    IF(LBANK.NE.LTOP)THEN
 127             LUP=LQ(KQSP+LBANK+1)
 128             IF(IOPTU.EQ.0)THEN
 129                CALL SBIT1(IQ(KQSP+LBANK),IQDROP)
 130             ELSE
 131                CALL MZDROP(JQPDVS,LBANK,' ')
 132                IQ(KQSP+LTOP+KIRIN)=0
 133             ENDIF
 134             LBANK=LUP
 135             IF(LBANK.NE.0)GO TO 40
 136          ENDIF
 137       ENDIF
 138 *
 139 *             Read Top Dir In Case Of U Option
 140 *
 141       IF(IOPTU.NE.0)CALL RZRTOP
 142 *
 143       IF(ISAVE.NE.0)THEN
 144          CALL RZSAVE
 145       ENDIF
 146 *
 147 *             Set new directory
 148 *
 149       CALL RZPATH(CHPATH)
 150       CALL RZFDIR('RZCDIR',LT,LDIR,COPTQ)
 151       IF(LDIR.NE.0)THEN
 152          NLCDIR= NLPAT
 153          LCDIR = LDIR
 154          LTOP  = LT
 155          DO 50 I=1,NLPAT
 156             CHCDIR(I)=CHPAT(I)
 157    50    CONTINUE
 158       ELSE
 159 *     Already set by RZFDIR
 160 *        IQUEST(1)=1
 161          IF(LCDIR.NE.0)CALL SBIT0(IQ(KQSP+LCDIR),IQDROP)
 162          GO TO 999
 163       ENDIF
 164
 165       LFREE  = LQ(KQSP+LTOP-2)
 166       LUSED  = LQ(KQSP+LTOP-3)
 167       LPURG  = LQ(KQSP+LTOP-5)
 168       LROUT  = LQ(KQSP+LTOP-6)
 169       LRIN   = LQ(KQSP+LTOP-7)
 170       LB     = IQ(KQSP+LTOP+KLB)
 171       LREC   = IQ(KQSP+LTOP+LB+1)
 172       LUN    = IQ(KQSP+LTOP-5)
 173       IZRECL = IQ(KQSP+LTOP+LB+1)
 174       IMODEC = JBIT(IQ(KQSP+LTOP),5)
 175       IMODEH = JBIT(IQ(KQSP+LTOP),6)
 176 #if defined(CERNLIB_FQXISN)
 177 *
 178 *     Set exchange mode bit
 179 *
 180       CALL SBIT1(IQ(KQSP+LTOP+KPW1+2),12)
 181       IMODEX = 1
 182 #endif
 183 #if !defined(CERNLIB_FQXISN)
 184       IMODEX = JBIT(IQ(KQSP+LTOP+KPW1+2),12)
 185 #endif
 186 #if defined(CERNLIB_QMVAX)
 187       IRELAT = JBIT(IQ(KQSP+LTOP),4)
 188 #endif
 189       IQUEST(7)=IQ(KQSP+LCDIR+KNKEYS)
 190       IQUEST(8)=IQ(KQSP+LCDIR+KNWKEY)
 191       IQUEST(9)=IQ(KQSP+LCDIR+KNSD)
 192       IQUEST(10)=IQ(KQSP+LCDIR+KQUOTA)
 193       IQUEST(11)=LCDIR
 194       IQUEST(12)=LTOP
 195       IQUEST(13)=IQ(KQSP+LCDIR+KLK)
 196       CALL RZDATE(IQ(KQSP+LCDIR+KDATEC),IDATEC,ITIMEC,1)
 197       CALL RZDATE(IQ(KQSP+LCDIR+KDATEM),IDATEM,ITIMEM,1)
 198       IQUEST(14)=IDATEC
 199       IQUEST(15)=ITIMEC
 200       IQUEST(16)=IDATEM
 201       IQUEST(17)=ITIMEM
 202       IQUEST(18)=IQ(KQSP+LCDIR+KRUSED)
 203       IQUEST(19)=IQ(KQSP+LCDIR+KMEGA)
 204       IQUEST(20)=IQ(KQSP+LCDIR+KWUSED)
 205       IQUEST(21)=IQ(KQSP+LCDIR+IQ(KQSP+LCDIR+KLD))
 206 *
 207 *             Check password
 208 *
 209       IF(JBYT(IQ(KQSP+LCDIR+KPW1+2),6,5).NE.0)THEN
 210          IF(IQ(KQSP+LCDIR+KPW1).NE.IHPWD(1).OR.
 211      +      IQ(KQSP+LCDIR+KPW1+1).NE.IHPWD(2))THEN
 212             CALL SBIT1(IQ(KQSP+LCDIR),1)
 213          ELSE
 214             CALL SBIT0(IQ(KQSP+LCDIR),1)
 215          ENDIF
 216       ENDIF
 217       IF(JBIT(IQ(KQSP+LTOP),1).NE.0)CALL SBIT1(IQ(KQSP+LCDIR),1)
 218 *
 219   999 END