MINICERN/packlib/zebra/dzebra/dzswap.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/24 17:26:18  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:07  mclareni
  10 * Zebra
  11 *
  12 *
  13 *----------------------------------------------------------
  14 #include "zebra/pilot.h"
  15       SUBROUTINE DZSWAP (IXSTOR,LSTR1,LSTR2,CHOPT)
  16
  17
  18 #include "zebra/mqsys.inc"
  19 #include "zebra/mzcn.inc"
  20 #include "zebra/qequ.inc"
  21 #include "zebra/zstate.inc"
  22 #include "zebra/zunit.inc"
  23 #include "zebra/storparq.inc"
  24 #include "zebra/dzc1.inc"
  25
  26       CHARACTER    *(*) CHOPT
  27       SAVE NAMESR
  28 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  29       DIMENSION    NAMESR(2)
  30       DATA  NAMESR / 4HZSWA, 4HP    /
  31 #endif
  32 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  33       DATA  NAMESR / 6HZSWAP  /
  34 #endif
  35 #if !defined(CERNLIB_QTRHOLL)
  36       CHARACTER    NAMESR*8
  37       DATA  NAMESR /  'ZSWAP   ' /
  38 #endif
  39 #include "zebra/q_jbit.inc"
  40 #include "zebra/q_jbyt.inc"
  41
  42 #include "zebra/qtrace.inc"
  43
  44       IF (IXSTOR.NE.NCHEKQ) CALL MZSDIV (IXSTOR,-1)
  45
  46       L1    = LSTR1
  47       L2    = LSTR2
  48
  49       IFLAG = INDEX(CHOPT,'R')
  50
  51
  52       IF (LQSTA(KQT+JQDVSY).EQ.LQEND(KQT+JQDVSY)) IFLAG = 0
  53
  54 #if defined(CERNLIB_QDEVZE)
  55       IF (NQDEVZ.NE.0) WRITE(IQPRNT,
  56      +'(''0DEVZE ZSWAP,  ENTRY:IXSTOR,LSTR1,LSTR2,IFLAG= '',Z8,3I8)')
  57      + IXSTOR,L1,L2,IFLAG
  58 #endif
  59
  60       IF (L1.EQ.0 .OR. L2.EQ.0)                            GO TO 999
  61
  62       CALL MZCHLS(NCHEKQ,L1)
  63       IF (IQFOUL.NE.0)                 THEN
  64           WRITE(IQPRNT,'(''0ZSWAP - BANK1 INVALID'')')
  65                                                            GO TO 998
  66       ENDIF
  67
  68       CALL MZCHLS(NCHEKQ,L2)
  69       IF (IQFOUL.NE.0)                 THEN
  70           WRITE(IQPRNT,'(''0ZSWAP - BANK2 INVALID'')')
  71                                                            GO TO 998
  72       ENDIF
  73
  74       LNEXT1 = LQ(KQS+L1)
  75       IF (LNEXT1.NE.0) CALL MZCHLS(NCHEKQ,LNEXT1)
  76       IF (IQFOUL.NE.0)                 THEN
  77           WRITE(IQPRNT,'(''0ZSWAP - Next of LSTR1 invalid'',2I8)')
  78      +     L1,LNEXT1
  79                                                            GO TO 998
  80       ENDIF
  81       LUP1   = LQLUP(KQS+L1)
  82       IF (LUP1.NE.0) CALL MZCHLS(NCHEKQ,LUP1)
  83       IF (IQFOUL.NE.0)                 THEN
  84           WRITE(IQPRNT,'(''0ZSWAP - Origin of LSTR1 invalid'',2I8)')
  85      +     L1,LUP1
  86                                                            GO TO 998
  87       ENDIF
  88       LSUP1  = LQLORG(KQS+L1)
  89       IF (LQ(KQS+LSUP1).NE.L1)         THEN
  90           WRITE(IQPRNT,'(''0ZSWAP - R link invalid (@r # LSTR1)'',
  91      +     2I8)') L1,LQ(KQS+LSUP1)
  92                                                            GO TO 998
  93       ENDIF
  94
  95       LNEXT2 = LQ(KQS+L2)
  96       IF (LNEXT2.NE.0) CALL MZCHLS(NCHEKQ,LNEXT2)
  97       IF (IQFOUL.NE.0)                 THEN
  98           WRITE(IQPRNT,'(''0ZSWAP - Next of LSTR2 invalid'',2I8)')
  99      +     L2,LNEXT2
 100                                                            GO TO 998
 101       ENDIF
 102       LUP2   = LQLUP(KQS+L2)
 103       IF (LUP2.NE.0) CALL MZCHLS(NCHEKQ,LUP2)
 104       IF (IQFOUL.NE.0)                 THEN
 105           WRITE(IQPRNT,'(''0ZSWAP - Origin of LSTR2 invalid'',2I8)')
 106      +     L2,LUP2
 107                                                            GO TO 998
 108       ENDIF
 109       LSUP2  = LQLORG(KQS+L2)
 110       IF (LQ(KQS+LSUP2).NE.L2)         THEN
 111           WRITE(IQPRNT,'(''0ZSWAP - R link invalid (@r # LSTR2)'',
 112      +     2I8)') L2,LQ(KQS+LSUP2)
 113                                                            GO TO 998
 114       ENDIF
 115
 116 #if defined(CERNLIB_QDEVZE)
 117       IF (NQDEVZ.NE.0) WRITE(IQPRNT,
 118      +'(''0DEVZE ZSWAP,  Before SWAP ,L1,N,O,P,@P '',5I8,/,
 119      +  ''       ZSWAP,  Before SWAP ,L2,N,O,P,@P '',5I8)')
 120      + L1,LQ(KQS+L1),LQLUP(KQS+L1),LQLORG(KQS+L1),
 121      + LQ(KQS+LQLORG(KQS+L1)),
 122      + L2,LQ(KQS+L2),LQLUP(KQS+L2),LQLORG(KQS+L2),
 123      + LQ(KQS+LQLORG(KQS+L2))
 124 #endif
 125
 126       IF (LNEXT1.EQ.L2) THEN
 127           LQ(KQS+L1)      = LNEXT2
 128           LQ(KQS+L2)      = L1
 129           LQLORG(KQS+L1)  = L2
 130           LQLORG(KQS+L2)  = LSUP1
 131           LQ(KQS+LSUP1)   = L2
 132           IF (LNEXT2.NE.0) LQLORG(KQS+LNEXT2) = L1
 133       ELSEIF(L1.EQ.LNEXT2) THEN
 134           LQ(KQS+L1)      = L2
 135           LQ(KQS+L2)      = LNEXT1
 136           LQLORG(KQS+L1)  = LSUP2
 137           LQLORG(KQS+L2)  = L1
 138           LQ(KQS+LSUP2)   = L1
 139           IF (LNEXT1.NE.0) LQLORG(KQS+LNEXT1) = L2
 140       ELSE
 141           LQ(KQS+L1)      = LNEXT2
 142           LQ(KQS+L2)      = LNEXT1
 143           LQLUP(KQS+L1)   = LUP2
 144           LQLUP(KQS+L2)   = LUP1
 145           LQLORG(KQS+L1)  = LSUP2
 146           LQLORG(KQS+L2)  = LSUP1
 147           LQ(KQS+LSUP1)   = L2
 148           LQ(KQS+LSUP2)   = L1
 149           IF (LNEXT1.NE.0) LQLORG(KQS+LNEXT1) = L2
 150           IF (LNEXT2.NE.0) LQLORG(KQS+LNEXT2) = L1
 151       ENDIF
 152
 153       LSTR1  = L2
 154       LSTR2  = L1
 155
 156 #if defined(CERNLIB_QDEVZE)
 157       IF (NQDEVZ.NE.0) WRITE(IQPRNT,
 158      +'(''0DEVZE ZSWAP,  After SWAP ,LSTR1,N,O,P,@P '',5I8,/,
 159      +  ''       ZSWAP,  After SWAP ,LSTR2,N,O,P,@P '',5I8)')
 160      + LSTR1,LQ(KQS+LSTR1),LQLUP(KQS+LSTR1),LQLORG(KQS+LSTR1),
 161      + LQ(KQS+LQLORG(KQS+LSTR1)),
 162      + LSTR2,LQ(KQS+LSTR2),LQLUP(KQS+LSTR2),LQLORG(KQS+LSTR2),
 163      + LQ(KQS+LQLORG(KQS+LSTR2))
 164 #endif
 165
 166
 167       IF (IFLAG.NE.0)      THEN
 168           LSYSB  = LQSYSS(KQT+MSYLAQ)
 169           IF(LSYSB.GT.0)                   THEN
 170               CALL MZCHLS(NCHEKQ,LSYSB)
 171               IF (IQFOUL.NE.0)                 THEN
 172                   WRITE(IQPRNT,
 173      X            '(''0ZSWAP - LINK AREA SYSTEM BANK INVALID'')')
 174                                                            GO TO 998
 175               ENDIF
 176
 177
 178               NWTAB  = IQ(KQS+LSYSB+MLAUSQ)
 179
 180
 181               LENTRY = LSYSB + KQS + MLAUSQ
 182
 183               DO 300 IENTRY = 1,(NWTAB-1)/NLAENQ
 184
 185                   LLAAR1 = IQ(LENTRY+MLAADQ) + KQS
 186                   LLAARL = IQ(LENTRY+MLALTQ) + KQS
 187                   NLANS  = IQ(LENTRY+MLANSQ)
 188                   JTEMP  = JBIT(NLANS,JLATMQ)
 189                   NTEMP  = NLATMQ*JTEMP
 190                   NLANS  = JBYT(IQ(LENTRY+MLANSQ),JLANSQ,NLANSQ) - NTEMP
 191                   IF(JTEMP.EQ.1.AND.LQ(LLAAR1+MLACTQ-1).EQ.0) GO TO 300
 192                   DO 200 I=LLAAR1+NTEMP+NLANS , LLAARL-1
 193                       IF (LQ(I).EQ.L1) THEN
 194                           LQ(I) = L2
 195                       ELSEIF(LQ(I).EQ.L2) THEN
 196                           LQ(I) = L1
 197                       ENDIF
 198   200             CONTINUE
 199
 200                   LENTRY = LENTRY + NLAENQ
 201   300         CONTINUE
 202
 203           ENDIF
 204
 205
 206
 207           IDIV1  = 1
 208           IF (L1.LT.LQEND(KQT+JQDVLL))                     GO TO 410
 209           IF (L1.GE.LQEND(KQT+NDVMXQ))                     GO TO 998
 210           IDIV1  = JQDVSY
 211
 212   410     IF (L1.LT.LQEND(KQT+IDIV1 ))                     GO TO 420
 213           IDIV1  = IDIV1  + 1
 214                                                            GO TO 410
 215
 216   420     IF (L1.LT.LQSTA(KQT+IDIV1 ))                     GO TO 998
 217
 218
 219           IDIV2  = 1
 220           IF (L2.LT.LQEND(KQT+JQDVLL))                     GO TO 510
 221           IF (L2.GE.LQEND(KQT+NDVMXQ))                     GO TO 998
 222           IDIV2  = JQDVSY
 223
 224   510     IF (L2.LT.LQEND(KQT+IDIV2 ))                     GO TO 520
 225           IDIV2  = IDIV2  + 1
 226                                                            GO TO 510
 227
 228   520     IF (L2.LT.LQSTA(KQT+IDIV2 ))                     GO TO 998
 229
 230 #if defined(CERNLIB_QDEVZE)
 231       IF (NQDEVZ.NE.0) WRITE(IQPRNT,
 232      +'(''0DEVZE ZSWAP,  Divs : L1,IDIV1,L2,IDIV2= '',4I8)')
 233      + L1,IDIV1,L2,IDIV2
 234 #endif
 235
 236
 237           DO 1700 JQDIVI = 1,NDVMXQ
 238               IF (JQDIVI.GT.JQDVLL.AND.JQDIVI.LT.JQDVSY)   GO TO 1700
 239
 240               LN = LQSTA(KQT+JQDIVI)
 241  1300         IF (LN.LT.LQEND(KQT+JQDIVI))       THEN
 242                   CALL MZCHLN(NCHEKQ,LN)
 243                   IF (IQFOUL.NE.0)                 THEN
 244                       WRITE(IQPRNT,
 245      X                '(''0ZSWAP - BANK INVALID AT'',I10)') LN
 246                                                            GO TO 998
 247                   ENDIF
 248                   LN = IQNX
 249                   IF (JBIT(IQ(KQS+IQLS),IQDROP).EQ.0)           THEN
 250                       DO 1400 L = IQLS-IQNL+KQS , IQLS-IQNS+KQS-1
 251                           IF (LQ(L).EQ.L1) THEN
 252                               LQ(L) = L2
 253                           ELSEIF(LQ(L).EQ.L2) THEN
 254                               LQ(L) = L1
 255                           ENDIF
 256  1400                 CONTINUE
 257                   ENDIF
 258                                                            GO TO 1300
 259               ENDIF
 260  1700     CONTINUE
 261
 262       ENDIF
 263
 264                                                            GO TO 999
 265
 266   998 CONTINUE
 267 #include "zebra/qtofatal.inc"
 268
 269 #include "zebra/qtrace99.inc"
 270       END