MINICERN/packlib/zebra/mq/mzflag.F

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