MINICERN/packlib/zebra/rz/rzver1.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/24 17:27:16  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:27  mclareni
  10 * Zebra
  11 *
  12 *
  13 #include "zebra/pilot.h"
  14       SUBROUTINE RZVER1(CHL,CHOPT,IRET)
  15 ************************************************************************
  16 *
  17 *     Slave routine to RZVERI
  18 *
  19 *
  20 *  Author  : J.Shiers CN/AS/DL
  21 *  Written : 23.03.92
  22 *  Last mod: 18.04.94 - set ISTAT2
  23 *          : 02.02.95 - cater for new RZ file format
  24 *
  25 ************************************************************************
  26 *
  27 #include "zebra/zunit.inc"
  28 #include "zebra/rzcl.inc"
  29 #include "zebra/rzk.inc"
  30 #include "zebra/rzclun.inc"
  31 #include "zebra/rzbmap.inc"
  32 #include "zebra/rzover.inc"
  33 #include "zebra/rzcycle.inc"
  34       CHARACTER*(*) CHL,CHOPT
  35       CHARACTER*255 DIRNAM
  36       DIMENSION KEY(KNMAX)
  37 *...............................................................
  38
  39 #include "zebra/q_jbit.inc"
  40 #include "zebra/q_jbyt.inc"
  41
  42       NCHL   = LENOCC(CHL)
  43       LOGLV  = JBYT(IQ(KQSP+LTOP),15,3)-3
  44       IF(LOGLV.GE.1) WRITE(IQPRNT,*)
  45      +   'Processing directory: ',CHL(1:NCHL)
  46       DIRNAM = CHL
  47       IRET   = 0
  48       JRET   = 0
  49       NKEYS  = IQ(KQSP+LCDIR+KNKEYS)
  50       NWKEY  = IQ(KQSP+LCDIR+KNWKEY)
  51       LB     = IQ(KQSP+LTOP+KLB)
  52       LK     = IQ(KQSP+LCDIR+KLK)
  53       LDS    = IQ(KQSP+LCDIR+KLD)
  54       LREC   = IZRECL
  55       NCHO   = LENOCC(CHOPT)
  56
  57       IOPTB  = INDEX(CHOPT(1:NCHO),'B')
  58       IOPTC  = INDEX(CHOPT(1:NCHO),'C')
  59       IOPTO  = INDEX(CHOPT(1:NCHO),'O')
  60       IOPTP  = INDEX(CHOPT(1:NCHO),'P')
  61 *
  62 *     Process all records of this directory
  63 *
  64       NRD      = IQ(KQSP+LCDIR+LDS)
  65       DO 10 I  = 1,NRD
  66
  67          ISTAT = 0
  68          IREC  = IQ(KQSP+LCDIR+LDS+I)
  69          IWORD = (IREC-1)/32 + 1
  70          IBIT  = IREC-32*(IWORD-1)
  71 *
  72 *     Print directory name and record number if rec. no in list
  73 *     of bad records
  74 *
  75           IF(IOPTP.NE.0.AND.NBAD.GT.0) THEN
  76              IF(IUFIND(IREC,IBAD,1,NBAD).LE.NBAD) WRITE(IQPRNT,*)
  77      +          'Directory: ',CHL(1:LENOCC(CHL)),' uses record ',IREC
  78           ENDIF
  79 *
  80 *     Is this record marked as free?
  81 *
  82          IF(IOPTC.NE.0.AND.
  83      +      JBIT(IQ(KQSP+LTOP+LB+2+IWORD),IBIT).EQ.0) THEN
  84             WRITE(IQPRNT,*) 'RZVER1. warning - record ',IREC,
  85      +         ' is in use but is marked as free in bit map'
  86             JRET = JRET + 1
  87          ENDIF
  88 *
  89 *     Set bit to mark record as used
  90 *
  91          IF(IOPTB.NE.0) CALL SBIT1(IQ(KQSP+LTOP+LB+2+IWORD),IBIT)
  92          IW1=(IREC-1)*LREC+1
  93          IW2=IW1+LREC-1
  94 *
  95 *     Check for overwriting at the directory level
  96 *
  97          IF(IOPTO.NE.0) CALL RZVER2(IW1,IW2,ISTAT)
  98          IRET=IRET+ISTAT
  99    10 CONTINUE
 100       IF(IRET.NE.0)THEN
 101          DIRNAM=CHL
 102          NCHL=LENOCC(CHL)
 103          PRINT 10000, DIRNAM(1:NCHL),(IQ(KQSP+LCDIR+LDS+I),I=1,NRD)
 104 *
 105 *     Store record numbers for second pass
 106 *
 107          IF(NBAD+NRD.LE.MAXBAD) THEN
 108             DO 20 I=1,NRD
 109                IBAD(NBAD+I) = IQ(KQSP+LCDIR+LDS+I)
 110    20       CONTINUE
 111             NBAD            = NBAD + NRD
 112          ENDIF
 113
 114       ENDIF
 115 *
 116 *     Check records used for objects in this directory
 117 *
 118       IF(NKEYS.GT.0)THEN
 119          DO 60 I=1,NKEYS
 120             ISTAT = 0
 121             LKC   = LK+(NWKEY+1)*(I-1)
 122             LCYC  = IQ(KQSP+LCDIR+LKC)
 123
 124    30       CONTINUE
 125
 126             IF(KVSCYC.EQ.0) THEN
 127                LCOLD = JBYT(IQ(KQSP+LCDIR+LCYC), 1,16)
 128                IR1   = JBYT(IQ(KQSP+LCDIR+LCYC+2),17,16)
 129                IR2   = JBYT(IQ(KQSP+LCDIR+LCYC ),17,16)
 130                IP1   = JBYT(IQ(KQSP+LCDIR+LCYC+2), 1,16)
 131                NW    = JBYT(IQ(KQSP+LCDIR+LCYC+3), 1,20)
 132             ELSE
 133                LCOLD = IQ(KQSP+LCDIR+LCYC)
 134                IR1   = IQ(KQSP+LCDIR+LCYC+2)
 135                IR2   = IQ(KQSP+LCDIR+LCYC+5)
 136                IP1   = JBYT(IQ(KQSP+LCDIR+LCYC+3),1,20)
 137                NW    = IQ(KQSP+LCDIR+LCYC+4)
 138             ENDIF
 139
 140             NLEFT=LREC-IP1+1
 141             IW1=(IR1-1)*LREC+IP1
 142             IW2=(IR1-1)*LREC+IP1+MIN(NLEFT,NW)-1
 143 *
 144 *     Check for overwriting at the object level
 145 *
 146             IF(IOPTO.NE.0) THEN
 147                CALL RZVER2(IW1,IW2,ISTAT)
 148                IF(ISTAT.NE.0.AND.NBAD.LT.MAXBAD) THEN
 149                   IBAD(NBAD+1) = IR1
 150                   NBAD         = NBAD + 1
 151                 ENDIF
 152             ENDIF
 153
 154             IWORD = (IR1-1)/32 + 1
 155             IBIT  = IR1-32*(IWORD-1)
 156 *
 157 *     Is this record marked as free?
 158 *
 159             IF(IOPTC.NE.0.AND.JBIT(IQ(KQSP+LTOP+LB+2+IWORD),IBIT)
 160      +      .EQ.0) THEN
 161                WRITE(IQPRNT,*) 'RZVER1. warning - record ',IR1,' is in '
 162      +         //'use but is marked as free in bit map'
 163                JRET = JRET + 1
 164             ENDIF
 165 *
 166 *     Set bit to mark record as used
 167 *
 168             IF(IOPTB.NE.0) CALL SBIT1(IQ(KQSP+LTOP+LB+2+IWORD),IBIT)
 169 *
 170 *     Is this record in the list of overwritten records?
 171 *
 172             IF(IOPTP.NE.0.AND.NBAD.GT.0) THEN
 173                IF(IUFIND(IR1,IBAD,1,NBAD).LE.NBAD) THEN
 174                   NCHL = LENOCC(CHL)
 175                   WRITE(IQPRNT,*) 'Directory: ',CHL(1:NCHL),
 176      +            ' has objects in record ',IR1
 177                   CALL RZPRNK(CHL(1:NCHL),I,LCYC,' ')
 178                ENDIF
 179             ENDIF
 180 *
 181 *     Any more records for this object?
 182 *
 183             IF(NW.GT.NLEFT)THEN
 184                NR=(NW-NLEFT-1)/LREC
 185                IRN=IR2+NR
 186                DO 40 J=IR2,IRN
 187                   IF(IOPTP.NE.0.AND.NBAD.GT.0) THEN
 188                      IF(IUFIND(J,IBAD,1,NBAD).LE.NBAD) THEN
 189                         NCHL = LENOCC(CHL)
 190                         WRITE(IQPRNT,*) 'Directory: ',
 191      +                    CHL(1:NCHL),' has objects in record ',IR1
 192                           CALL RZPRNK(CHL(1:NCHL),I,LCYC,' ')
 193                      ENDIF
 194                   ENDIF
 195
 196                   IWORD = (J-1)/32 + 1
 197                   IBIT  = J-32*(IWORD-1)
 198 *
 199 *     Is this record marked as free?
 200 *
 201                   IF(IOPTC.NE.0.AND.JBIT(IQ(KQSP+LTOP+LB+2+IWORD),
 202      +            IBIT).EQ.0) THEN
 203                      WRITE(IQPRNT,*) 'RZVER1. warning - record ',J,
 204      +               ' is in use but is marked as free in bit map'
 205                      JRET = JRET + 1
 206                   ENDIF
 207 *
 208 *     Set bit to mark record as used
 209 *
 210                   IF(IOPTB.NE.0) CALL SBIT1(IQ(KQSP+LTOP+LB+2+IWORD),
 211      +            IBIT)
 212    40          CONTINUE
 213                IW1=(IR2-1)*LREC+1
 214                IW2=IW1+NW-NLEFT-1
 215                ISTAT2=0
 216                IF(IOPTO.NE.0) CALL RZVER2(IW1,IW2,ISTAT2)
 217                ISTAT=ISTAT+ISTAT2
 218             ENDIF
 219             IF(ISTAT2.NE.0.AND.NW.GT.NLEFT)THEN
 220                DO 50 J=IR2,IRN
 221                   IF(NBAD.LT.MAXBAD) THEN
 222                      IBAD(NBAD+1) = J
 223                      NBAD         = NBAD + 1
 224                   ENDIF
 225    50          CONTINUE
 226                ICYC = JBYT(IQ(KQSP+LCDIR+LCYC+3),21,12)
 227                DIRNAM=CHL
 228                NCHL=LENOCC(CHL)
 229                IRET=IRET+1
 230 *
 231 *     Get and print key of corrupted object
 232 *
 233                PRINT 10100, DIRNAM(1:NCHL),IR1,((NW-1)/LREC)+1
 234                CALL RZPRNK(DIRNAM(1:NCHL),I,LCYC,' ')
 235             ENDIF
 236             IF(LCOLD.NE.0.AND.LCOLD.NE.LCYC)THEN
 237                LCYC=LCOLD
 238                GO TO 30
 239             ENDIF
 240    60    CONTINUE
 241       ENDIF
 242
 243       IQUEST(2) = JRET
 244 *
 245 10000 FORMAT(' **** WARNING: Directory ',A,' possibly overwritten ****',
 246      +       /,' records numbers: ',/10(1X,I6))
 247 10100 FORMAT(' **** WARNING: Object in directory ',A,' corrupted ****',
 248      +       /,' start record: ',I6,' number of records: ',I6)
 249 *
 250       END