MINICERN/packlib/zebra/mq/mzcopy.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:11:19  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 MZCOPY (IXDVFR,LENTP,IXDVTO,LSUPP,JBIASP,CHOPT)
  14
  15 C-    Copy a data-structure, User called
  16
  17 #include "zebra/zbcd.inc"
  18 #include "zebra/zstate.inc"
  19 #include "zebra/zunit.inc"
  20 #include "zebra/zvfaut.inc"
  21 #include "zebra/mqsys.inc"
  22 #include "zebra/mzct.inc"
  23 #include "zebra/mzcn.inc"
  24 #include "zebra/fzcx.inc"
  25 C--------------    END CDE                             --------------
  26       DIMENSION    IXDVFR(9),LENTP(9),IXDVTO(9),LSUPP(9),JBIASP(9)
  27       CHARACTER    CHOPT*(*)
  28       DIMENSION    LADESV(6)
  29 #if defined(CERNLIB_QMVDS)
  30       SAVE         LADESV
  31 #endif
  32 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  33       DIMENSION    NAMESR(2)
  34       DATA  NAMESR / 4HMZCO, 4HPY   /
  35 #endif
  36 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  37       DATA  NAMESR / 6HMZCOPY /
  38 #endif
  39 #if !defined(CERNLIB_QTRHOLL)
  40       CHARACTER    NAMESR*8
  41       PARAMETER   (NAMESR = 'MZCOPY  ')
  42 #endif
  43       DATA  LADESV / 6, 5*0 /
  44
  45 #include "zebra/q_locf.inc"
  46
  47 #include "zebra/qtrace.inc"
  48 #if defined(CERNLIB_QDEBUG)
  49       IF (IQVSTA.NE.0)       CALL ZVAUTX
  50 #endif
  51
  52       LENTRX = LENTP(1)
  53       LSUP   = LSUPP(1)
  54       NWBKFR = IQUEST(1)
  55       NOFFFR = IQUEST(2)
  56       NWBKMX = IQUEST(3)
  57       NOFFTO = IQUEST(4)
  58       CALL UOPTC (CHOPT,'DISZMLNPFT',IOPTXD)
  59       JFLGAX = 0
  60       IHANDL = 0
  61       NWBKU  = -7
  62       LOGLEV = NQLOGD
  63
  64 C----              TO option  yes / no
  65
  66       IF (IOPTXT.NE.0)  THEN
  67           LOCTO  = LOCF(IXDVTO(1)) - 1 - NOFFTO
  68           KSQTO  = LOCTO - LQASTO
  69           JSTOTO = -2
  70         ELSE
  71           IXDIVI = IXDVTO(1)
  72           CALL MZSDIV (IXDIVI,7)
  73           IF (JQDIVI.EQ.0)         GO TO 97
  74           KSQTO  = KQS
  75           JSTOTO = JQSTOR
  76           JDIVTO = JQDIVI
  77           JDMODE = IQMODE(KQT+JQDIVI)
  78           NWBKMX = NQDMAX(KQT+JQDIVI)
  79           LOGLEV = MAX (LOGLEV,NQLOGL)
  80           LQSYSR(KQT+2) = LSUP
  81         ENDIF
  82
  83 C----              FROM option  yes / no
  84
  85       IF (IOPTXF.NE.0)  THEN
  86           LOCFR  = LOCF(IXDVFR(1)) - 1 - NOFFFR
  87           KSQFR  = LOCFR - LQASTO
  88           JSTOFR = -1
  89           NWBKX  = NWBKFR
  90           IOPTXD = 1
  91           IOPTXL = 1
  92         ELSE
  93           IXDIVX = IXDVFR(1)
  94           CALL MZSDIV (IXDIVX,0)
  95           KSQFR  = KQS
  96           JSTOFR = JQSTOR
  97           LOGLEV = MAX (LOGLEV,NQLOGL)
  98           LQSYSR(KQT+1) = LENTRX
  99           IF ((JSTOFR.EQ.JSTOTO).AND.(IOPTXZ.EQ.0))  IHANDL=-1
 100         ENDIF
 101 #if defined(CERNLIB_QDEBPRI)
 102       IF (LOGLEV.GE.2)
 103      + WRITE (IQLOG,9009) JSTOFR,JSTOTO,CHOPT
 104  9009 FORMAT (' MZCOPY-  Store From/To =',2I3,' Options = ',A)
 105 #endif
 106
 107 C----------        Table building         ----------------------
 108
 109    11 MODTBX = 1
 110       IQPART = 0
 111
 112 C----              TO option  yes / no
 113
 114       JQSTMV = -1
 115       IF (IOPTXT.NE.0)             GO TO 21
 116
 117 C--                TO option  no
 118
 119       IF (NWBKU.GE.0)       GO TO 21
 120       JQSTMV = JSTOTO
 121       JQDVM1 = JDIVTO
 122       JQDVM2 = JDIVTO
 123       NQDVMV = 1 - 2*JDMODE
 124       IQTNMV = -7
 125
 126 C----              FROM option  yes / no
 127
 128    21 IF (IOPTXF.EQ.0)             GO TO 24
 129
 130       JQGAPM = 0
 131       JQGAPR = 0
 132       LQRTA  = LQWKTB
 133       LQTA   = LQRTA + 2
 134       LQTE   = LQTA  + 4
 135       LQRTE  = LQTE  + 1
 136       LQMTA  = LQRTE + 2
 137
 138       LQ(LQTA)   = NOFFFR + 1
 139       LQ(LQTA+1) = LQ(LQTA) + NWBKX
 140       GO TO 33
 141
 142 C--                FROM option  no
 143
 144    24 IF (JQSTOR.NE.JSTOFR)  CALL MZSDIV (IXDIVX,0)
 145
 146       CALL FZOTAB
 147       IF (IQUEST(1).EQ.0)          GO TO 31
 148       IF (IQUEST(1).EQ.1)          GO TO 11
 149       IF (IQUEST(2).NE.13)         GO TO  91
 150       IF (JFLGAX.GE.3)             GO TO  93
 151
 152 C--                Collect garbage in the TO space, if no room
 153
 154       JFLGAX = 3
 155       IF (JSTOTO.EQ.JQSTOR)        GO TO  93
 156       IF (JSTOTO.LE.0)             GO TO  93
 157
 158       IXGARB = MZIXCO (IXDIVI,21,22,23)
 159       IXGARB = MZIXCO (IXGARB,24,0,0)
 160       CALL MZGARB (IXGARB,0)
 161       GO TO 11
 162
 163 C----------        Reserve target space     --------------------
 164
 165    31 CONTINUE
 166 #if defined(CERNLIB_QDEVZE)
 167       IF (NQDEVZ.LT.7)             GO TO 33
 168       WRITE (IQLOG,9831) LQMTA,LQMTE
 169  9831 FORMAT (1X/' DEVZE MZCOPY,  Memory Occupation Table,'
 170      F,' LQMTA,LQMTE= ',2I8/16X,
 171      F' DIV ACT     NWS    LFBK  LLBK+1     JFE     JLE    FREE')
 172
 173       WRITE (IQLOG,9832) (LQ(J),J=LQMTA,LQMTE-1)
 174  9832 FORMAT (16X,2I4,6I8)
 175 #endif
 176    33 IF (NWBKX.GT.NWBKMX)         GO TO  94
 177       IF (NWBKX.EQ.0)              GO TO  95
 178       IF (IOPTXT.NE.0)             GO TO 41
 179       IF (JQSTOR.NE.JSTOTO)  CALL MZSDIV (IXDIVI,0)
 180       IF (NWBKU.GE.0)       GO TO 37
 181
 182       JQDIVI = JDIVTO
 183       CALL MZRESV
 184       NQRESV = NQRESV - NWBKX
 185       IF (NQRESV.LT.0)  THEN
 186           CALL MZGAR1
 187           IQPART = -7
 188           IF (JSTOTO.EQ.JSTOFR)  LENTRX=LQSYSR(KQT+1)
 189         ENDIF
 190
 191       IF (JDMODE.EQ.0)  THEN
 192           LTO  = LQEND(KQT+JDIVTO)
 193           LTOE = LTO + NWBKX
 194           LQEND(KQT+JDIVTO) = LTOE
 195         ELSE
 196           LTOE = LQSTA(KQT+JDIVTO)
 197           LTO  = LTOE - NWBKX
 198           LQSTA(KQT+JDIVTO) = LTO
 199         ENDIF
 200       IF (IQPART.EQ.0)             GO TO 42
 201
 202       LQ(KQS+LTO)   = 12
 203       LQ(KQS+LTO+1) = 0
 204       LQ(KQS+LTO+2) = 0
 205       LQ(KQS+LTO+3) = 0
 206       LQ(KQS+LTO+4) = 0
 207       LQ(KQS+LTO+5) = IQLETT(1)
 208       LQ(KQS+LTO+6) = 0
 209       LQ(KQS+LTO+7) = 0
 210       LQ(KQS+LTO+8) = NWBKX - 10
 211       LQ(KQS+LTO+9) = 0
 212       NWBKU = NWBKX
 213       GO TO 11
 214
 215 C----              Target space already reserved, get it
 216
 217    37 NDIF  = NWBKX - NWBKU
 218       IF (JDMODE.EQ.0)  THEN
 219           LTOE = LQEND(KQT+JDIVTO)
 220           LTO  = LTOE - NWBKU
 221           IF (NDIF.EQ.0)           GO TO 42
 222           LTOE = LTOE + NDIF
 223           LQEND(KQT+JDIVTO) = LTOE
 224         ELSE
 225           LTO  = LQSTA(KQT+JDIVTO)
 226           LTOE = LTO + NWBKU
 227           IF (NDIF.EQ.0)           GO TO 42
 228           LTO = LTO - NDIF
 229           LQSTA(KQT+JDIVTO) = LTO
 230         ENDIF
 231       GO TO 42
 232
 233 C----------        Move material to destination    -------------
 234
 235 C--                TO option yes
 236
 237    41 LTO    = NOFFTO + 1
 238       LTOE   = LTO + NWBKX
 239       JQSTOR = -1
 240       LQSTOR = LOCTO
 241       KQS    = KSQTO
 242       KQT    = KQFT
 243
 244       LQFSTA(1)  = LTO
 245       LQFSTA(21) = LTOE
 246       GO TO 44
 247
 248 C--                TO option no
 249
 250    42 NWBKU = NWBKX
 251       LSUP  = LQSYSR(KQT+2)
 252
 253    44 LTOA = LTO
 254       NREL = LTO
 255       LFRE = 0
 256       LTB  = LQTA
 257
 258    46 LFR  = LQ(LTB)
 259       NREL = NREL - (LFR-LFRE)
 260       LFRE = LQ(LTB+1)
 261
 262       LQ(LTB+2) = NREL
 263       LQ(LTB+3) = IHANDL
 264
 265       NW  = LFRE - LFR
 266       CALL UCOPY (LQ(KSQFR+LFR), LQ(KSQTO+LTO), NW)
 267       LTO = LTO + NW
 268       LTB = LTB + 4
 269       IF (LTB.LT.LQTE)             GO TO 46
 270
 271 C----------        Relocation        ---------------------------
 272
 273       LQ(LQMTA+1) = 1
 274       LQ(LQMTA+3) = LTOA
 275       LQ(LQMTA+4) = LTOE
 276       LQMTE = LQMTA + 8
 277       IF (IOPTXN.NE.0)             GO TO 61
 278
 279       LQ(LQTE)   = LQ(LQTE-3)
 280       LQ(LQTA-1) = LQ(LQTA)
 281
 282       IF (IHANDL.LT.0)  THEN
 283 C--          retain links pointing outside the d/s
 284           IQFLIO = 0
 285         ELSE
 286 C--          zero links pointing outside
 287           IQFLIO = 7
 288         ENDIF
 289 #if defined(CERNLIB_QDEVZE)
 290       IF (NQDEVZ.LT.7)             GO TO 56
 291       LQ(LQMTA)   = 0
 292       LQ(LQMTA+2) = 0
 293       LQ(LQMTA+5) = 0
 294       LQ(LQMTA+6) = 0
 295       LQ(LQMTA+7) = 0
 296
 297       WRITE (IQLOG,9853) LQRTA,LQTA,LQTE,LQ(LQTA-1)
 298  9853 FORMAT (1X/' DEVZE MZCOPY,  Link Relocation Table,'
 299      F,' LQRTA,LQTA,LQTE= ',3I8
 300      F/16X,'   LOC       L      LE    NREL  BG'
 301      F/28X,I10)
 302
 303       IF (LQTE.LE.LQTA)            GO TO 55
 304       I  = LQRTA
 305       JA = LQTA - I
 306       JE = LQTE - I - 1
 307       WRITE (IQLOG,9854) (J,LQ(I+J),LQ(I+J+1),LQ(I+J+2),LQ(I+J+3),
 308      +                                           J=JA,JE,4)
 309  9854 FORMAT (16X,I6,3I8,I4)
 310
 311    55 WRITE (IQLOG,9855) LQ(LQTE)
 312  9855 FORMAT (20X,I10)
 313    56 CONTINUE
 314 #endif
 315       CALL MZRELB
 316       IF (IQFLIO.LT.0)             GO TO  96
 317
 318 C--                Relocate the entry link
 319
 320       LADESV(2) = LOCF(LENTRX) - LQSTOR
 321       LADESV(3) = LADESV(2) + 1
 322       LADESV(5) = IQLETT(9)
 323       LADESV(6) = IQLETT(15)
 324       CALL MZRELL (LADESV)
 325
 326       IF (IOPTXL.EQ.0)  LQ(KQS+LENTRX)=0
 327       LQ(KQS+LENTRX+1) = 0
 328       LQ(KQS+LENTRX+2) = 0
 329       GO TO 64
 330
 331 C--                No-link option
 332
 333    61 CALL FZILIN
 334       IF (IQFOUL.NE.0)             GO TO  96
 335       LENTRX = IQUEST(1)
 336
 337 C----              Connect d/s
 338
 339    64 IF (IOPTXT.NE.0)  THEN
 340           LSUPP(1)  = LENTRX
 341           JBIASP(1) = NWBKX
 342         ELSE
 343           JB = JBIASP(1)
 344           LSUPP(1) = LQSYSR(KQT+2)
 345           CALL ZSHUNT (IXDIVI,LENTRX,LSUPP,JB,1)
 346         ENDIF
 347
 348       IQUEST(1) = 0
 349       IQUEST(2) = NWBKX
 350 #include "zebra/qtrace99.inc"
 351       RETURN
 352
 353 C----------        Error conditions      -----------------------
 354
 355 C--                LENTRX invalid / Bank chaning clobbered in FZOTAB
 356
 357    91 IQUEST(2) = IQUEST(2) - 10
 358       GO TO 98
 359
 360 C--                Not enough table space
 361
 362    93 IQUEST(2) = 3
 363       GO TO 98
 364
 365 C--                D/s larger than the target space
 366
 367    94 IQUEST(2) = 4
 368       IQUEST(11) = NWBKX
 369       IQUEST(12)= NWBKMX
 370       GO TO 98
 371
 372 C--                D/s empty
 373
 374    95 IQUEST(2) = 5
 375       GO TO 98
 376
 377 C--                MZRELB or FZILIN find bank chaining clobbered
 378
 379    96 IQUEST(2) = 6
 380       GO TO 98
 381
 382 C--                Target division not specified
 383
 384    97 IQUEST(2) = 7
 385
 386    98 CONTINUE
 387       IF (NWBKU.GE.0)  THEN
 388           IF (JQSTOR.NE.JSTOTO)  CALL MZSDIV (IXDIVI,0)
 389           IF (JDMODE.EQ.0)  THEN
 390               LQEND(KQT+JDIVTO) = LQEND(KQT+JDIVTO) - NWBKU
 391             ELSE
 392               LQSTA(KQT+JDIVTO) = LQSTA(KQT+JDIVTO) + NWBKU
 393             ENDIF
 394         ENDIF
 395
 396       IF (IOPTXP.EQ.0)  CALL ZTELL (15,1)
 397       IQUEST(1) = IQUEST(2)
 398       GO TO 999
 399       END
 400 *      ==================================================
 401 #include "zebra/qcardl.inc"