MINICERN/packlib/zebra/fq/fzirel.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:10:43  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:15  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       SUBROUTINE FZIREL
  14
  15 C-    RELOCATE DATA-STRUCTURE READ
  16 C-    USE THE MEMORY OCCUPATION TABLE READY
  17 C-    AND THE RELOCATION VECTOR READ INTO LQ(LQTA+NWTABI)
  18 C-    CALLED FROM FZIN
  19
  20 #include "zebra/zbcd.inc"
  21 #include "zebra/zmach.inc"
  22 #include "zebra/zunit.inc"
  23 #include "zebra/mqsys.inc"
  24 #include "zebra/eqlqf.inc"
  25 #include "zebra/mzcn.inc"
  26 #include "zebra/mzct.inc"
  27 #include "zebra/fzci.inc"
  28 C--------------    End CDE                             --------------
  29       DIMENSION    LADESV(6)
  30 #if defined(CERNLIB_QMVDS)
  31       SAVE         LADESV
  32 #endif
  33 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  34       DIMENSION    NAMESR(2)
  35       DATA  NAMESR / 4HFZIR, 4HEL   /
  36 #endif
  37 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  38       DATA  NAMESR / 6HFZIREL /
  39 #endif
  40 #if !defined(CERNLIB_QTRHOLL)
  41       CHARACTER    NAMESR*8
  42       PARAMETER   (NAMESR = 'FZIREL  ')
  43 #endif
  44       DATA  LADESV / 6, 5*0 /
  45
  46
  47 #include "zebra/qtrace.inc"
  48
  49       IF (NWTABI.EQ.0)             GO TO 61
  50
  51 C------            Ready the relocation table
  52
  53       LPUT  = LQTA
  54       LTAKE = LQTA + NWTABI
  55
  56 C--                Loop for all segments in the memory occupation tb.
  57
  58       LMT = LQMTA
  59    22 IF (LQ(LMT+1).NE.0)          GO TO 24
  60
  61 C--                Skipped segment
  62
  63       NWSG  = LQ(LMT+3)
  64    23 IF (NWSG.GE.0)               GO TO 29
  65       IF (LTAKE.GE.LQTE)           GO TO 731
  66       NWSG  = NWSG + (LQ(LTAKE+1)-LQ(LTAKE))
  67       LTAKE = LTAKE + 2
  68       GO TO 23
  69
  70 C--                Accepted segment
  71
  72    24 LSTA  = LQ(LMT+3)
  73       LEND  = LQ(LMT+4)
  74       NWSG  = LSTA - LEND
  75       NREL  = 0
  76       LE    = LSTA
  77    25 IF (LTAKE.GE.LQTE)           GO TO 731
  78       LA    = LQ(LTAKE)
  79       NREL  = NREL - (LA-LE)
  80       LE    = LQ(LTAKE+1)
  81
  82       LQ(LPUT)   = LA
  83       LQ(LPUT+1) = LE
  84       LQ(LPUT+2) = NREL
  85       LQ(LPUT+3) = 0
  86       LTAKE = LTAKE + 2
  87       LPUT  = LPUT  + 4
  88       NWSG  = NWSG + (LE-LA)
  89       IF (NWSG.LT.0)               GO TO 25
  90    29 IF (NWSG.NE.0)               GO TO 732
  91       LMT = LMT + 8
  92       IF (LMT.LT.LQMTE)            GO TO 22
  93       IF (LTAKE.NE.LQTE)           GO TO 733
  94       LQTE = LPUT
  95
  96       LQ(LQTE)   =  LQ(LQTE-3)
  97       LQ(LQTA-1) =  LQ(LQTA)
  98 #if defined(CERNLIB_QDEVZE)
  99       IF (LOGLVI.GE.4)
 100      +  WRITE (IQLOG,9167) LENTRI,(LQ(J),J=LQTA,LQTE-1)
 101  9167 FORMAT (' FZIREL-  Relocation Table, LENTRY before=',I10/
 102      F (15X,3I9,I4))
 103 #endif
 104
 105 C----              Relocate the bank links
 106
 107       IQFLIO = 7
 108       CALL MZRELB
 109       IF (IQFLIO.LT.0)             GO TO 734
 110
 111 C--                Relocate the entry link
 112
 113       LADESV(2) = LOCF(LENTRI) - LQSTOR
 114       LADESV(3) = LADESV(2) + 1
 115       LADESV(5) = IQLETT(9)
 116       LADESV(6) = IQLETT(15)
 117       CALL MZRELL (LADESV)
 118 #if defined(CERNLIB_QDEVZE)
 119       IF (LOGLVI.GE.4)  WRITE (IQLOG,9037) LENTRI
 120  9037 FORMAT (10X,'LENTRY after=',I10)
 121 #endif
 122       LQ(KQS+LENTRI+1) = 0
 123       LQ(KQS+LENTRI+2) = 0
 124       GO TO 999
 125
 126 C------            Chain banks into one linear structure
 127
 128    61 CALL FZILIN
 129       IF (IQFOUL.NE.0)             GO TO 734
 130       LENTRI = IQUEST(1)
 131 #include "zebra/qtrace99.inc"
 132       RETURN
 133
 134 C-------------------------------------------------
 135 C-                 ERROR CONDITIONS
 136 C-------------------------------------------------
 137
 138 C----              BAD DATA
 139
 140 C-    JERROR = 34  bank chaining clobbered in the input data
 141   734 JERROR = 34
 142       IQUEST(14)= IQLN
 143       NWERR  = 1
 144       GO TO 739
 145
 146 C-    JERROR = 33  ends of segment and rel. tables do not match
 147   733 JERROR = 33
 148       IQUEST(14)= LTAKE
 149       IQUEST(15)= LQTE
 150       NWERR  = 2
 151       GO TO 739
 152
 153 C-    JERROR = 32  segment limit does not match a rel. table entry
 154   732 JERROR = 32
 155       IQUEST(14)= NWSG
 156       NWERR  = 1
 157       GO TO 739
 158
 159 C-    JERROR = 31  segment table tries to overshoot rel. table
 160   731 JERROR = 31
 161       IQUEST(14)= NWSG
 162       NWERR  = 1
 163   739 JRETCD = 5
 164       GO TO 999
 165       END
 166 *      ==================================================
 167 #include "zebra/qcardl.inc"