MINICERN/packlib/zebra/mq/mzlink.F

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