MINICERN/packlib/zebra/mq/mzrepl.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:12:04  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 MZREPL (IXDIV,LIXP,CHOPT)
  14
  15 C-    Link replacement banks and relocate, 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/eqlqmst.inc"
  22 #include "zebra/mzcl.inc"
  23 #include "zebra/mzcn.inc"
  24 #include "zebra/mzct.inc"
  25 C--------------    End CDE                             --------------
  26       DIMENSION    IXDIV(9),LIXP(9)
  27       CHARACTER    CHOPT*(*)
  28 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  29       DIMENSION    NAMESR(2)
  30       DATA  NAMESR / 4HMZRE, 4HPL   /
  31 #endif
  32 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  33       DATA  NAMESR / 6HMZREPL /
  34 #endif
  35 #if !defined(CERNLIB_QTRHOLL)
  36       CHARACTER    NAMESR*8
  37       PARAMETER   (NAMESR = 'MZREPL  ')
  38 #endif
  39
  40 #include "zebra/q_sbit1.inc"
  41 #include "zebra/q_locf.inc"
  42
  43 #include "zebra/qtrace.inc"
  44
  45       CALL MZSDIV (IXDIV,7)
  46
  47       CALL UOPTC (CHOPT,'KI',IQUEST)
  48       IFLAG = IQUEST(1)
  49       ISOLA = IQUEST(2)
  50
  51 C-         IFLAG = 0  drop old and index
  52 C-                 1  keep old and index
  53
  54       IXGARB = 0
  55       LIXO  = LIXP(1)
  56 #if defined(CERNLIB_QDEBPRI)
  57       IF (NQLOGL.LT.2)             GO TO 12
  58       WRITE (IQLOG,9001) JQSTOR,JQDIVI,LIXO,CHOPT
  59  9001 FORMAT (1X/' MZREPL-  Store/Div/Lix/CHOPT :',2I3,I8,1X,A)
  60
  61 #endif
  62 #if defined(CERNLIB_QDEBUG)
  63       IF (IQVSTA.NE.0)       CALL ZVAUTX
  64 #endif
  65 #if defined(CERNLIB_QDEVZE)
  66       IF (NQDEVZ.LT.3)             GO TO 12
  67       WRITE (IQLOG,9811)
  68  9811 FORMAT (1X/20X,'Lix   link 1        link 2')
  69  9824 FORMAT (5X,3I9,1X,A4,I9,1X,A4)
  70 #endif
  71
  72    12 IF (LIXO.EQ.0)               GO TO 999
  73
  74 C--       Find division
  75
  76       IF (JQDIVI.EQ.0)  THEN
  77           JQDIVI = MZFDIV (-7, LQ(KQS+LIXO-1))
  78           IF (JQDIVI.EQ.0)         GO TO 91
  79         ENDIF
  80
  81       LIMDLO = LQSTA(KQT+JQDIVI)
  82       LIMDUP = LQEND(KQT+JQDIVI)
  83
  84 C--       Get the number of index banks
  85
  86       LIX  = LIXO
  87       NIX  = 0
  88    24 NIX  = NIX + 1
  89 #if defined(CERNLIB_QDEBUG)
  90
  91 C--       check index bank valid
  92       CALL MZCHLS (-7,LIX)
  93       IF (IQFOUL.NE.0)             GO TO 93
  94       LOLD = LQ(KQS+LIX-1)
  95       LNEW = LQ(KQS+LIX-2)
  96
  97       IF (IQ(KQS+LIX-3).LT.2)         GO TO 94
  98       IF (IFLAG.NE.0)  THEN
  99           IF (IQ(KQS+LIX-1).EQ.0)     GO TO 94
 100         ENDIF
 101
 102 C--       check old/new all in same division
 103       IF (LOLD.LT.LIMDLO)          GO TO 95
 104       IF (LOLD.GE.LIMDUP)          GO TO 95
 105       IF (LNEW.LT.LIMDLO)          GO TO 95
 106       IF (LNEW.GE.LIMDUP)          GO TO 95
 107
 108 C--       check old/new valid banks
 109       CALL MZCHLS (-7,LOLD)
 110       IF (IQFOUL.NE.0)             GO TO 96
 111
 112       CALL MZCHLS (-7,LNEW)
 113       IF (IQFOUL.NE.0)             GO TO 97
 114
 115 C--       check origin-link consistent
 116       K = LQ(KQS+LOLD+2)
 117       IF (K.NE.0)  THEN
 118           IF (LQ(KQS+K).NE.LOLD)      GO TO 98
 119         ENDIF
 120
 121 C--       check next-link consistent
 122       L = LQ(KQS+LOLD)
 123       IF (L.NE.0)  THEN
 124           IF (LQ(KQS+L+2).NE.LOLD)    GO TO 99
 125         ENDIF
 126
 127 #endif
 128 #if defined(CERNLIB_QDEVZE)
 129       IF (NQDEVZ.GE.3)  WRITE (IQLOG,9824) NIX,LIX,
 130      +                     LOLD,IQ(KQS+LOLD-4),LNEW,IQ(KQS+LNEW-4)
 131 #endif
 132       LIX  = LQ(KQS+LIX)
 133       IF (LIX.NE.0)                GO TO 24
 134       IF (ISOLA.NE.0)              GO TO 61
 135
 136 C--       Re-link the index structure to MZ working link
 137
 138       CALL MZCHNB (LIXP)
 139       LQSYSR(KQT+1)  = LQ(KQS+LIXO+1)
 140       LQSYSR(KQT+2)  = LQ(KQS+LIXO+2)
 141       LQMST(KQT+1)   = LIXO
 142       LQ(KQS+LIXO+2) = LOCF (LQMST(KQT+1)) - LQSTOR
 143       IF (NIX.EQ.1)                GO TO 31
 144
 145 C--       Sort the index banks for increasing LOLD
 146
 147       LIXN = LQ(KQS+LIXO)
 148       IF (LQ(KQS+LIXN-1).LT.LQ(KQS+LIXO-1))  THEN
 149           CALL ZTOPSY (IXDIV,LIXO)
 150           LIXO  = LQMST(KQT+1)
 151         ENDIF
 152
 153       CALL ZSORTI (IXDIV,LIXO,-9)
 154       LIXO  = LQMST(KQT+1)
 155 #if defined(CERNLIB_QDEVZE)
 156       IF (NQDEVZ.LT.3)             GO TO 31
 157       WRITE (IQLOG,9811)
 158       LIX  = LIXO
 159       JIX  = 1
 160    27 LOLD = LQ(KQS+LIX-1)
 161       LNEW = LQ(KQS+LIX-2)
 162       WRITE (IQLOG,9824) JIX,LIX,
 163      +                   LOLD,IQ(KQS+LOLD-4),LNEW,IQ(KQS+LNEW-4)
 164       LIX  = LQ(KQS+LIX)
 165       JIX  = JIX + 1
 166       IF (LIX.NE.0)                GO TO 27
 167 #endif
 168
 169 C------            Relocation
 170
 171    31 MQDVGA = 0
 172       MQDVWI = 0
 173       JQSTMV = -1
 174
 175       CALL MZTABM
 176
 177       LMT  = LQMTA - 8
 178    34 LMT  = LMT + 8
 179       IF (LQ(LMT).NE.JQDIVI)       GO TO 34
 180       LQ(LMT+1) = 2
 181
 182       CALL MZTABX
 183       LQMTE = LQMTLU
 184
 185 C--       construct the link relocation table
 186
 187       IFIRST = 7
 188       LIX  = LIXO
 189    37 LOLD = LQ(KQS+LIX-1)
 190       LNEW = LQ(KQS+LIX-2)
 191
 192 #if !defined(CERNLIB_QDEBUG)
 193       IF (LOLD.LT.LIMDLO)          GO TO 95
 194       IF (LOLD.GE.LIMDUP)          GO TO 95
 195       IF (LNEW.LT.LIMDLO)          GO TO 95
 196       IF (LNEW.GE.LIMDUP)          GO TO 95
 197 #endif
 198       NL  = IQ(KQS+LOLD-3)
 199       ND  = IQ(KQS+LOLD-1)
 200       NLC = MIN (IQ(KQS+LNEW-3), NL)
 201       NDC = MIN (IQ(KQS+LNEW-1), ND)
 202
 203       IF (IFIRST.NE.0)  THEN
 204           LQ(LQTA-1) = LOLD - NLC
 205           LQTE  = LQTA
 206           IFIRST = 0
 207         ELSE
 208           LQ(LQTE)   = LQ(LQTE-3)
 209           LQ(LQTE+1) = LOLD - NLC
 210           LQ(LQTE+2) = 0
 211           LQ(LQTE+3) = 0
 212           LQTE = LQTE + 4
 213         ENDIF
 214
 215       LQ(LQTE)   = LOLD - NLC
 216       LQ(LQTE+1) = LOLD + NDC + 9
 217       LQ(LQTE+2) = LNEW - LOLD
 218       LQ(LQTE+3) = 0
 219
 220       LQTE = LQTE + 4
 221       IF (LQTE.GE.LQRTE)  THEN
 222           CALL MZTABH
 223           IF (IQPART.NE.0)         GO TO 51
 224         ENDIF
 225       LIX  = LQ(KQS+LIX)
 226       IF (LIX.NE.0)                GO TO 37
 227
 228       LQ(LQTE) = LQ(LQTE-3)
 229
 230 C--       Structural replacement of old by new
 231
 232       LIX  = LIXO
 233    42 LOLD = LQ(KQS+LIX-1)
 234       LNEW = LQ(KQS+LIX-2)
 235       LQ(KQS+LNEW)   = LQ(KQS+LOLD)
 236       LQ(KQS+LNEW+1) = LQ(KQS+LOLD+1)
 237       LQ(KQS+LNEW+2) = LQ(KQS+LOLD+2)
 238       LQ(KQS+LOLD)   = 0
 239       LQ(KQS+LOLD+1) = LIX
 240       LQ(KQS+LOLD+2) = LIX - 1
 241       IQ(KQS+LOLD-2) = 0
 242       IQ(KQS+LIX-2)  = 1
 243       IF (IFLAG.NE.0)  THEN
 244 C--       the old banks to remain accessible
 245           IQ(KQS+LIX+1) = LQ(KQS+LIX-1)
 246         ELSE
 247           IQ(KQS+LOLD) = MSBIT1(IQ(KQS+LOLD),IQDROP)
 248         ENDIF
 249       LQ(KQS+LIX-1)  = 0
 250       LIX  = LQ(KQS+LIX)
 251       IF (LIX.NE.0)                GO TO 42
 252
 253 C--                Relocate
 254
 255       CALL MZRELX
 256
 257 C------            Finished, reset LIX
 258
 259       LIXP(1)     = LIXO
 260       LQ(KQS+LIXO+1) = LQSYSR(KQT+1)
 261       LQ(KQS+LIXO+2) = LQSYSR(KQT+2)
 262       LQMST(KQT+1) = 0
 263
 264       IF (IFLAG.EQ.0)  THEN
 265           CALL MZDROP (IXDIV, LIXO, 'L')
 266           GO TO 999
 267         ENDIF
 268
 269 C--       restore LOLD's in the index structure
 270
 271 #if defined(CERNLIB_QDEVZE)
 272       IF (NQDEVZ.GE.3)  THEN
 273           WRITE (IQLOG,9811)
 274           JIX  = 1
 275         ENDIF
 276 #endif
 277       LIX  = LIXO
 278    47 LOLD = IQ(KQS+LIX+1)
 279       LQ(KQS+LIX-1) = LOLD
 280 #if defined(CERNLIB_QDEVZE)
 281       IF (NQDEVZ.GE.3)  THEN
 282           LNEW = LQ(KQS+LIX-2)
 283           WRITE (IQLOG,9824) JIX,LIX,
 284      +                   LOLD,IQ(KQS+LOLD-4),LNEW,IQ(KQS+LNEW-4)
 285           JIX  = JIX + 1
 286         ENDIF
 287 #endif
 288       LIX  = LQ(KQS+LIX)
 289       IF (LIX.NE.0)                GO TO 47
 290 #include "zebra/qtrace99.inc"
 291       RETURN
 292
 293 C----     Not enough table space, collect garbage
 294
 295    51 IF (IXGARB.NE.0)             GO TO 92
 296
 297       JDIVSV = JQDIVI
 298
 299       IXGARB = MZIXCO (IXDIV, 21, 22, 24)
 300       CALL MZGARB (IXGARB, 0)
 301
 302       LIXO   = LQMST(KQT+1)
 303       JQDIVI = JDIVSV
 304 #if !defined(CERNLIB_QDEBUG)
 305       LIMDLO = LQSTA(KQT+JQDIVI)
 306       LIMDUP = LQEND(KQT+JQDIVI)
 307 #endif
 308       GO TO 31
 309
 310 C--------          Isolated case, update structural links  ---------
 311
 312    61 LIX  = LIXO
 313    62 LOLD = LQ(KQS+LIX-1)
 314       LNEW = LQ(KQS+LIX-2)
 315       LQ(KQS+LNEW)   = LQ(KQS+LOLD)
 316       LQ(KQS+LNEW+1) = LQ(KQS+LOLD+1)
 317       LQ(KQS+LNEW+2) = LQ(KQS+LOLD+2)
 318
 319 C----              Update according to origin-link
 320
 321       K = LQ(KQS+LNEW+2)
 322       IF (K.NE.0)  LQ(KQS+K) = LNEW
 323
 324 C----              Update according to next-link
 325
 326       L = LQ(KQS+LNEW)
 327       IF (L.NE.0)  LQ(KQS+L+2) = LNEW
 328
 329 C----              Update k- and up-link in vertically dependent banks
 330
 331       JBIAS = IQ(KQS+LNEW-2) + 1
 332    64 JBIAS = JBIAS - 1
 333       IF (JBIAS.LE.0)              GO TO 68
 334       KO = LOLD - JBIAS
 335       KN = LNEW - JBIAS
 336       L  = LQ(KQS+KN)
 337       IF (L.EQ.0)                  GO TO 64
 338       IF (LQ(KQS+L+2).NE.KO)          GO TO 64
 339       LQ(KQS+L+2) = KN
 340
 341 C--                          and its linear structure
 342
 343       LF = L
 344    67 LQ(KQS+L+1) = LNEW
 345       L = LQ(KQS+L)
 346       IF (L.EQ.LF)                 GO TO 64
 347       IF (L.NE.0)                  GO TO 67
 348       GO TO 64
 349
 350    68 LQ(KQS+LOLD)   = 0
 351       IQ(KQS+LOLD-2) = 0
 352       IQ(KQS+LIX-2)  = 1
 353       IF (IFLAG.NE.0)  THEN
 354           LQ(KQS+LOLD+1) = LIX
 355           LQ(KQS+LOLD+2) = LIX - 1
 356         ELSE
 357           LQ(KQS+LOLD+1) = 0
 358           LQ(KQS+LOLD+2) = 0
 359           IQ(KQS+LOLD)   = MSBIT1(IQ(KQS+LOLD),IQDROP)
 360           LQ(KQS+LIX-1)  = 0
 361         ENDIF
 362       LIX  = LQ(KQS+LIX)
 363       IF (LIX.NE.0)                GO TO 62
 364
 365       IF (IFLAG.EQ.0)  CALL MZDROP (IXDIV, LIXO, 'L')
 366       GO TO 999
 367
 368 C-----------       Error conditions
 369
 370    99 NQCASE = 1
 371    98 NQCASE = NQCASE + 5
 372       NQFATA = 4
 373       IQUEST(15) = LNEW
 374       IQUEST(16) = LOLD
 375       IQUEST(17) = LQ(KQS+LOLD+2)
 376       IQUEST(18) = LQ(KQS+LOLD)
 377       GO TO 93
 378
 379    97 NQCASE = 1
 380    96 NQCASE = NQCASE + 1
 381    95 NQCASE = NQCASE + 1
 382    94 NQCASE = NQCASE + 1
 383       NQFATA = NQFATA + 5
 384       IQUEST(15) = IQ(KQS+LIX-3)
 385       IQUEST(16) = IQ(KQS+LIX-2)
 386       IQUEST(17) = IQ(KQS+LIX-1)
 387       IQUEST(18) = LOLD
 388       IQUEST(19) = LNEW
 389
 390    93 NQCASE = NQCASE + 1
 391       NQFATA = NQFATA + 3
 392       IQUEST(12) = LIMDLO
 393       IQUEST(13) = LIMDUP
 394       IQUEST(14) = LIX
 395
 396    92 NQCASE = NQCASE + 1
 397    91 NQCASE = NQCASE + 1
 398       NQFATA = NQFATA + 1
 399       IQUEST(11) = JQDIVI
 400 #include "zebra/qtofatal.inc"
 401       END
 402 *      ==================================================
 403 #include "zebra/qcardl.inc"