MINICERN/packlib/zebra/mq/mzlint.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:11:40  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:18  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       SUBROUTINE MZLINT (IXSTOR,CHNAME,LAREA,LREF,LREFL)
  14
  15 C-    Set permanent link area, 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 C--------------    End CDE                             --------------
  23       DIMENSION    LAREA(9),LREF(9),LREFL(9),NAME(2)
  24       CHARACTER    *(*) CHNAME
  25 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  26       DIMENSION    NAMESR(2)
  27       DATA  NAMESR / 4HMZLI, 4HNT   /
  28 #endif
  29 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  30       DATA  NAMESR / 6HMZLINT /
  31 #endif
  32 #if !defined(CERNLIB_QTRHOLL)
  33       CHARACTER    NAMESR*8
  34       PARAMETER   (NAMESR = 'MZLINT  ')
  35 #endif
  36
  37 #include "zebra/q_jbyt.inc"
  38 #include "zebra/q_sbit1.inc"
  39 #include "zebra/q_locf.inc"
  40
  41
  42 #include "zebra/qtrace.inc"
  43
  44 #include "zebra/qstore.inc"
  45 #if defined(CERNLIB_QDEBUG)
  46       IF (IQVSTA.NE.0)       CALL ZVAUTX
  47 #endif
  48
  49       LSYS  = LQSYSS(KQT+1)
  50       NWTAB = IQ(KQS+LSYS+1)
  51       LOCAR = LOCF (LAREA(1)) - LQSTOR
  52 #if defined(CERNLIB_APOLLO)
  53       LOCAR = RSHFT (IADDR(LAREA(1)),2) - LQSTOR
  54 #endif
  55       JDES = LAREA(2)
  56       IF (JDES.LT.11)              GO TO 21
  57       IF (JDES.GE.NWTAB)           GO TO 21
  58       LSTO = LSYS + JDES
  59       IF (IQ(KQS+LSTO+1).NE.LOCAR)    GO TO 21
  60       NL = IQ(KQS+LSTO+2) - LOCAR
  61 #if defined(CERNLIB_QDEBPRI)
  62       IF (NQLOGL.LT.2)             GO TO 19
  63       WRITE (IQLOG,9018) IQ(KQS+LSTO+4),IQ(KQS+LSTO+5),JQSTOR
  64  9018 FORMAT (1X/' MZLINT-  Re-Init of Link Area ',2A4,'  for Store',I3)
  65 #endif
  66
  67 C--                Set link area active
  68
  69    19 LAREA(1) = 7
  70       CALL VZERO (LAREA(3),NL-2)
  71 #include "zebra/qtrace99.inc"
  72       RETURN
  73
  74 C------            Initialize for the first time
  75
  76    21 IF (NWTAB+5.GT.IQ(KQS+LSYS-1))  THEN
  77           JQDIVI = JQDVSY
  78           CALL MZPUSH (-7,LSYS,0,100,'I')
  79           LQSYSS(KQT+1) = LSYS
  80         ENDIF
  81
  82       LSTO = LSYS + NWTAB
  83       LOCR  = LOCF (LREF(1))  - LQSTOR
  84       LOCRL = LOCF (LREFL(1)) - LQSTOR
  85 #if defined(CERNLIB_APOLLO)
  86       LOCR  = RSHFT (IADDR(LREF(1)),2)  - LQSTOR
  87       LOCRL = RSHFT (IADDR(LREFL(1)),2) - LQSTOR
  88 #endif
  89       NS = LOCR    - LOCAR
  90       NL = LOCRL+1 - LOCAR
  91       IF (NL.EQ.1)  THEN
  92           NS = NS + 1
  93           NL = NS
  94         ENDIF
  95
  96       LOCARE = LOCAR + NL
  97       MODAR  = MSBIT1 (NS,31)
  98
  99       NAME(1) = IQBLAN
 100       NAME(2) = IQBLAN
 101       N = MIN (8, LEN(CHNAME))
 102       IF (N.NE.0)  CALL UCTOH (CHNAME,NAME,4,N)
 103
 104       IQ(KQS+LSTO+1) = LOCAR
 105       IQ(KQS+LSTO+2) = LOCARE
 106       IQ(KQS+LSTO+3) = MODAR
 107       IQ(KQS+LSTO+4) = NAME(1)
 108       IQ(KQS+LSTO+5) = NAME(2)
 109
 110 C--                Range of possible values for an origin-link
 111
 112       IQTABV(KQT+13) = MIN (IQTABV(KQT+13), LOCAR+2)
 113       IQTABV(KQT+14) = MAX (IQTABV(KQT+14), LOCARE)
 114
 115       NSM2 = NS - 2
 116       NLM2 = NL - 2
 117 #if defined(CERNLIB_QPRINT)
 118       IF (NQLOGL.GE.1)
 119      +WRITE (IQLOG,9039) NAME,JQSTOR,NLM2,NSM2
 120  9039 FORMAT (1X/' MZLINT.  Initialize Link Area  ',2A4,'  for Store'
 121      F,I3,' NL/NS=',2I6)
 122
 123 #endif
 124 #if defined(CERNLIB_QDEBUG)
 125
 126 C----              Check valid parameters
 127
 128       IF (LOCR .LT.LOCAR)          GO TO 91
 129       IF (LOCRL.LT.LOCAR)          GO TO 91
 130       IF (NL.LT.NS)                GO TO 91
 131
 132 C------            Check overlap with existing stores
 133
 134       KLA = KQS + LOCAR
 135       KLE = KQS + LOCARE
 136
 137 #endif
 138 #if defined(CERNLIB_QDEVZE)
 139       IF (NQDEVZ.GE.7)
 140      +WRITE (IQLOG,9841) 4*LQSTOR, 4*LQATAB, 4*LQBTIS, 4*KLA
 141      +,           LQSTOR,LQATAB, LQBTIS,KLA
 142      +,           LQSTOR,LQATAB, LQBTIS,KLA
 143  9841 FORMAT (1X/' DEVZE MZLINT.  ',17X,'LQSTOR',17X,'LQATAB',
 144      F17X,'LQBTIS',20X,'KLA'
 145 #endif
 146 #if (defined(CERNLIB_QDEVZE))&&(!defined(CERNLIB_HEX))
 147      F/10X,'4* OCT',4O23/13X,'OCT',4O23/13X,'DEC',4I23)
 148 #endif
 149 #if (defined(CERNLIB_QDEVZE))&&(defined(CERNLIB_HEX))
 150      F/10X,'4* HEX',4Z23/13X,'HEX',4Z23/13X,'DEC',4I23)
 151 #endif
 152 #if defined(CERNLIB_QDEVZE)
 153       IF (NQDEVZ.GE.7)   WRITE (IQLOG,9842) KLA,KLE
 154  9842 FORMAT (16X,' KLA/KLE=',2I10)
 155 #endif
 156 #if defined(CERNLIB_QDEBUG)
 157
 158       DO 47  JSTO=1,NQSTOR+1
 159       IF (NQALLO(JSTO).NE.0)       GO TO 47
 160       JT  = NQOFFT(JSTO)
 161       JS  = NQOFFS(JSTO)
 162       JSA = JS  - IQTABV(JT+2) + 1
 163       JSE = JS  + LQSTA(JT+21) + 1
 164       JTA = JT  + LQBTIS       + 1
 165       JTE = JTA + NQTSYS
 166
 167 #endif
 168 #if defined(CERNLIB_QDEVZE)
 169       IF (NQDEVZ.GE.7)   WRITE (IQLOG,9843) JTA,JTE,  JSA,JSE
 170  9843 FORMAT (16X,' JTA/JTE=',2I10,'  JSA/JSE=',2I10)
 171 #endif
 172 #if defined(CERNLIB_QDEBUG)
 173
 174       IF (KLE.GT.JTA .AND. KLA.LT.JTE)    GO TO 92
 175       IF (KLE.GT.JSA .AND. KLA.LT.JSE)    GO TO 93
 176
 177 C--                Check overlap with existing link areas
 178
 179       L = JS+ LQSYSS(JT+1)
 180       N = IQ(L+1)
 181       IF (N.LT.12)                 GO TO 47
 182
 183       DO 44  J=12,N,5
 184       JLA = JS + IQ(L+J)
 185       JLE = JS + IQ(L+J+1)
 186
 187 #endif
 188 #if defined(CERNLIB_QDEVZE)
 189       IF (NQDEVZ.GE.7)   WRITE (IQLOG,9844) JLA,JLE
 190  9844 FORMAT (16X,' JLA/JLE=',2I10)
 191 #endif
 192 #if defined(CERNLIB_QDEBUG)
 193
 194       IF (KLE.GT.JLA .AND. KLA.LT.JLE)    GO TO 94
 195    44 CONTINUE
 196    47 CONTINUE
 197 #endif
 198
 199 C--                Success, register new link area
 200
 201       LAREA(2) = NWTAB
 202       IQ(KQS+LSYS+1) = NWTAB + 5
 203       GO TO 19
 204
 205 C------            Error conditions
 206
 207    94 NQCASE = 1
 208       NQFATA = 4
 209       IQUEST(21) = IQ(L+J+3)
 210       IQUEST(22) = IQ(L+J+4)
 211       IQUEST(23) = JLA + LQSTOR
 212       IQUEST(24) = LAREA(2)
 213
 214    93 NQCASE = NQCASE + 1
 215    92 NQCASE = NQCASE + 1
 216       NQFATA = NQFATA + 3
 217       IQUEST(18) = JSTO - 1
 218       IQUEST(19) = NQPNAM(JT+1)
 219       IQUEST(20) = NQPNAM(JT+2)
 220
 221    91 NQCASE = NQCASE + 1
 222       NQFATA = NQFATA + 7
 223       IQUEST(11) = NAME(1)
 224       IQUEST(12) = NAME(2)
 225       IQUEST(13) = LOCAR + LQSTOR
 226       IQUEST(14) = LOCR  + LQSTOR
 227       IQUEST(15) = LOCRL + LQSTOR
 228       IQUEST(16) = NSM2
 229       IQUEST(17) = NLM2
 230 #include "zebra/qtofatal.inc"
 231       END
 232 *      ==================================================
 233 #include "zebra/qcardl.inc"