MINICERN/packlib/zebra/mq/mzvolm.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:12:08  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:19  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       FUNCTION MZVOLM (IXSTOR,LHEADP,CHOPT)
  14
  15 C-    Run through d/s to calculate space occupied, user called
  16
  17 #include "zebra/zstate.inc"
  18 #include "zebra/zunit.inc"
  19 #include "zebra/zvfaut.inc"
  20 #include "zebra/mqsys.inc"
  21 #include "zebra/mzcn.inc"
  22 #include "zebra/mzcwk.inc"
  23 C--------------    End CDE                             --------------
  24       DIMENSION    LHEADP(9)
  25       CHARACTER    *(*) CHOPT
  26 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  27       DIMENSION    NAMESR(2)
  28       DATA  NAMESR / 4HMZVO, 4HLM   /
  29 #endif
  30 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  31       DATA  NAMESR / 6HMZVOLM /
  32 #endif
  33 #if !defined(CERNLIB_QTRHOLL)
  34       CHARACTER    NAMESR*8
  35       PARAMETER   (NAMESR = 'MZVOLM  ')
  36 #endif
  37
  38 #include "zebra/q_jbit.inc"
  39 #include "zebra/q_jbyt.inc"
  40 #include "zebra/q_sbit0.inc"
  41 #include "zebra/q_sbit1.inc"
  42
  43
  44 #include "zebra/qtrace.inc"
  45       NWVOL = 0
  46       LHEAD = LHEADP(1)
  47       IF (LHEAD.EQ.0)              GO TO 999
  48
  49 #include "zebra/qstore.inc"
  50
  51 #if defined(CERNLIB_QDEBUG)
  52       IF (IQVSTA.NE.0)       CALL ZVAUTX
  53       CALL MZCHLS (-7,LHEAD)
  54       IF (IQFOUL.NE.0)             GO TO 92
  55 #endif
  56 #if !defined(CERNLIB_QDEBUG)
  57       IQNS = IQ(KQS+LHEAD-2)
  58 #endif
  59
  60       CALL UOPTC (CHOPT,'L',IQUEST)
  61       IOPTH  = IQUEST(1)
  62 #if defined(CERNLIB_QDEVZE)
  63       IF (NQDEVZ.NE.0)
  64      +WRITE (IQLOG,9814) LHEAD,IOPTH
  65  9814 FORMAT (1X/' DEVZE MZVOLM.   LHEAD,IOPTH='
  66      F,I6,6I4)
  67 #endif
  68
  69       LEV  = LQWKTB + 3
  70       LEVE = LEV + NQWKTB - 10
  71       LQ(LEV-2) = 0
  72       LQ(LEV-1) = 0
  73       LQ(LEV)   = LHEAD
  74
  75       LCUR = LHEAD
  76       LX   = LHEAD - 1 + IOPTH
  77       LAST = LHEAD - IQNS
  78       IQ(KQS+LCUR) = MSBIT1 (IQ(KQS+LCUR),IQSYSX)
  79       GO TO 24
  80
  81 C--                Mark bank
  82
  83    20 LAST = LCUR - IQ(KQS+LCUR-2)
  84       IQ(KQS+LNEW) = MSBIT0 (IQ(KQS+LNEW),IQSYSX)
  85       NWVOL  = NWVOL + 10 + JBYT (IQ(KQS+LNEW),19,4) +
  86      +                      IQ(KQS+LNEW-1) + IQ(KQS+LNEW-3)
  87
  88 C----              Look at next link
  89
  90    24 IF (LX.LT.LAST)              GO TO 41
  91       LNEW = LQ(KQS+LX)
  92       LX   = LX - 1
  93       IF (LNEW.EQ.0)               GO TO 24
  94
  95 #if defined(CERNLIB_QDEBUG)
  96       CALL MZCHLS (-7,LNEW)
  97       IF (IQFOUL.NE.0)             GO TO 94
  98 #endif
  99       IF (JBIT(IQ(KQS+LNEW),IQSYSX).NE.0)   GO TO 24
 100
 101 C----              New bank LNEW, push down
 102
 103       LQ(LEV+1) = LX
 104       LQ(LEV+2) = LCUR
 105
 106       LEV = LEV + 3
 107       IF (LEV.GE.LEVE)             GO TO 91
 108       LQ(LEV)   = LNEW
 109 #if defined(CERNLIB_QDEVZE)
 110       IF (NQDEVZ.GE.11)
 111      +WRITE (IQLOG,9831) LEV,LCUR,LX+1,LNEW
 112  9831 FORMAT (' DEVZE MZVOLM,  Down:   LEV,LCUR,LX+1,LNEW=',6I8)
 113 #endif
 114
 115 C--                Move to end of linear structure
 116
 117    32 LCUR = LNEW
 118       IQ(KQS+LCUR) = MSBIT1 (IQ(KQS+LCUR),IQSYSX)
 119       LNEW = LQ(KQS+LCUR)
 120       IF (LNEW.EQ.0)               GO TO 36
 121 #if defined(CERNLIB_QDEVZE)
 122       IF (NQDEVZ.GE.11)
 123      +WRITE (IQLOG,9833) LCUR,LNEW
 124  9833 FORMAT (' DEVZE MZVOLM,  Along:  LCUR,LNEW=',6I8)
 125 #endif
 126 #if defined(CERNLIB_QDEBUG)
 127       CALL MZCHLS (-7,LNEW)
 128       IF (IQFOUL.NE.0)             GO TO 93
 129       IF (JBIT(IQ(KQS+LNEW),IQSYSX).NE.0)  GO TO 36
 130       IF (LQ(KQS+LNEW+2).NE.LCUR)          GO TO 95
 131       GO TO 32
 132
 133    36 CONTINUE
 134 #endif
 135 #if !defined(CERNLIB_QDEBUG)
 136       IF (JBIT(IQ(KQS+LNEW),IQSYSX).EQ.0)  GO TO 32
 137
 138    36 IQNS = IQ(KQS+LCUR-2)
 139 #endif
 140       LAST = LCUR - IQNS
 141       LX   = LCUR - 1
 142       GO TO 24
 143
 144 C----              Bank at LCUR has no further secondaries
 145 C--                     step back in the linear structure
 146
 147    41 LNEW = LCUR
 148       IF (LCUR.EQ.LQ(LEV))         GO TO 46
 149       LCUR = LQ(KQS+LCUR+2)
 150       LX   = LCUR - 1
 151 #if defined(CERNLIB_QDEVZE)
 152       IF (NQDEVZ.GE.11)
 153      +WRITE (IQLOG,9841) LCUR,LNEW
 154  9841 FORMAT (' DEVZE MZVOLM,  Back:   LCUR,LNEW=',6I8)
 155 #endif
 156       GO TO 20
 157
 158 C--                Start of linear structure reached, pop up
 159
 160    46 LEV  = LEV - 3
 161       LX   = LQ(LEV+1)
 162       LCUR = LQ(LEV+2)
 163 #if defined(CERNLIB_QDEVZE)
 164       IF (NQDEVZ.GE.11)
 165      +WRITE (IQLOG,9846) LEV,LCUR,LX
 166  9846 FORMAT (' DEVZE MZVOLM,  Up:     LEV,LCUR,LX=',6I8)
 167 #endif
 168       IF (LCUR.NE.0)               GO TO 20
 169
 170 C----              Done, mark header bank
 171
 172    61 IQ(KQS+LHEAD) = MSBIT0 (IQ(KQS+LHEAD),IQSYSX)
 173       NWVOL  = NWVOL + 10 + JBYT (IQ(KQS+LHEAD),19,4) +
 174      +                      IQ(KQS+LHEAD-1) + IQ(KQS+LHEAD-3)
 175 #include "zebra/qtrace99.inc"
 176       MZVOLM = NWVOL
 177       RETURN
 178
 179 C------            Error conditions
 180
 181 #if defined(CERNLIB_QDEBUG)
 182    95 NQCASE = 2
 183       NQFATA = 1
 184       IQUEST(14) = LQ(KQS+LNEW+2)
 185       GO TO 93
 186
 187    94 NQCASE = 1
 188       NQFATA = 1
 189       IQUEST(14) = LX+1 - LCUR
 190    93 NQCASE = NQCASE + 1
 191       NQFATA = NQFATA + 2
 192       IQUEST(12) = LNEW
 193       IQUEST(13) = LCUR
 194    92 NQCASE = NQCASE + 1
 195 #endif
 196    91 NQCASE = NQCASE + 1
 197       NQFATA = NQFATA + 1
 198       IQUEST(11) = LHEAD
 199 #include "zebra/qtofatal.inc"
 200       MZVOLM = 0
 201       END
 202 *      ==================================================
 203 #include "zebra/qcardl.inc"