[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / mq / mzlint.F

*
* $Id$
*
* $Log$
* Revision 1.2  1996/04/18 16:11:40  mclareni
* Incorporate changes from J.Zoll for version 3.77
*
* Revision 1.1.1.1  1996/03/06 10:47:18  mclareni
* Zebra
*
*
#include "zebra/pilot.h"
      SUBROUTINE MZLINT (IXSTOR,CHNAME,LAREA,LREF,LREFL)

C-    Set permanent link area, user called

#include "zebra/zbcd.inc"
#include "zebra/zstate.inc"
#include "zebra/zunit.inc"
#include "zebra/zvfaut.inc"
#include "zebra/mqsys.inc"
C--------------    End CDE                             --------------
      DIMENSION    LAREA(9),LREF(9),LREFL(9),NAME(2)
      CHARACTER    *(*) CHNAME
#if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
      DIMENSION    NAMESR(2)
      DATA  NAMESR / 4HMZLI, 4HNT   /
#endif
#if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
      DATA  NAMESR / 6HMZLINT /
#endif
#if !defined(CERNLIB_QTRHOLL)
      CHARACTER    NAMESR*8
      PARAMETER   (NAMESR = 'MZLINT  ')
#endif

#include "zebra/q_jbyt.inc"
#include "zebra/q_sbit1.inc"
#include "zebra/q_locf.inc"


#include "zebra/qtrace.inc"

#include "zebra/qstore.inc"
#if defined(CERNLIB_QDEBUG)
      IF (IQVSTA.NE.0)       CALL ZVAUTX
#endif

      LSYS  = LQSYSS(KQT+1)
      NWTAB = IQ(KQS+LSYS+1)
      LOCAR = LOCF (LAREA(1)) - LQSTOR
#if defined(CERNLIB_APOLLO)
      LOCAR = RSHFT (IADDR(LAREA(1)),2) - LQSTOR
#endif
      JDES = LAREA(2)
      IF (JDES.LT.11)              GO TO 21
      IF (JDES.GE.NWTAB)           GO TO 21
      LSTO = LSYS + JDES
      IF (IQ(KQS+LSTO+1).NE.LOCAR)    GO TO 21
      NL = IQ(KQS+LSTO+2) - LOCAR
#if defined(CERNLIB_QDEBPRI)
      IF (NQLOGL.LT.2)             GO TO 19
      WRITE (IQLOG,9018) IQ(KQS+LSTO+4),IQ(KQS+LSTO+5),JQSTOR
 9018 FORMAT (1X/' MZLINT-  Re-Init of Link Area ',2A4,'  for Store',I3)
#endif

C--                Set link area active

   19 LAREA(1) = 7
      CALL VZERO (LAREA(3),NL-2)
#include "zebra/qtrace99.inc"
      RETURN

C------            Initialize for the first time

   21 IF (NWTAB+5.GT.IQ(KQS+LSYS-1))  THEN
          JQDIVI = JQDVSY
          CALL MZPUSH (-7,LSYS,0,100,'I')
          LQSYSS(KQT+1) = LSYS
        ENDIF

      LSTO = LSYS + NWTAB
      LOCR  = LOCF (LREF(1))  - LQSTOR
      LOCRL = LOCF (LREFL(1)) - LQSTOR
#if defined(CERNLIB_APOLLO)
      LOCR  = RSHFT (IADDR(LREF(1)),2)  - LQSTOR
      LOCRL = RSHFT (IADDR(LREFL(1)),2) - LQSTOR
#endif
      NS = LOCR    - LOCAR
      NL = LOCRL+1 - LOCAR
      IF (NL.EQ.1)  THEN
          NS = NS + 1
          NL = NS
        ENDIF

      LOCARE = LOCAR + NL
      MODAR  = MSBIT1 (NS,31)

      NAME(1) = IQBLAN
      NAME(2) = IQBLAN
      N = MIN (8, LEN(CHNAME))
      IF (N.NE.0)  CALL UCTOH (CHNAME,NAME,4,N)

      IQ(KQS+LSTO+1) = LOCAR
      IQ(KQS+LSTO+2) = LOCARE
      IQ(KQS+LSTO+3) = MODAR
      IQ(KQS+LSTO+4) = NAME(1)
      IQ(KQS+LSTO+5) = NAME(2)

C--                Range of possible values for an origin-link

      IQTABV(KQT+13) = MIN (IQTABV(KQT+13), LOCAR+2)
      IQTABV(KQT+14) = MAX (IQTABV(KQT+14), LOCARE)

      NSM2 = NS - 2
      NLM2 = NL - 2
#if defined(CERNLIB_QPRINT)
      IF (NQLOGL.GE.1)
     +WRITE (IQLOG,9039) NAME,JQSTOR,NLM2,NSM2
 9039 FORMAT (1X/' MZLINT.  Initialize Link Area  ',2A4,'  for Store'
     F,I3,' NL/NS=',2I6)

#endif
#if defined(CERNLIB_QDEBUG)

C----              Check valid parameters

      IF (LOCR .LT.LOCAR)          GO TO 91
      IF (LOCRL.LT.LOCAR)          GO TO 91
      IF (NL.LT.NS)                GO TO 91

C------            Check overlap with existing stores

      KLA = KQS + LOCAR
      KLE = KQS + LOCARE

#endif
#if defined(CERNLIB_QDEVZE)
      IF (NQDEVZ.GE.7)
     +WRITE (IQLOG,9841) 4*LQSTOR, 4*LQATAB, 4*LQBTIS, 4*KLA
     +,           LQSTOR,LQATAB, LQBTIS,KLA
     +,           LQSTOR,LQATAB, LQBTIS,KLA
 9841 FORMAT (1X/' DEVZE MZLINT.  ',17X,'LQSTOR',17X,'LQATAB',
     F17X,'LQBTIS',20X,'KLA'
#endif
#if (defined(CERNLIB_QDEVZE))&&(!defined(CERNLIB_HEX))
     F/10X,'4* OCT',4O23/13X,'OCT',4O23/13X,'DEC',4I23)
#endif
#if (defined(CERNLIB_QDEVZE))&&(defined(CERNLIB_HEX))
     F/10X,'4* HEX',4Z23/13X,'HEX',4Z23/13X,'DEC',4I23)
#endif
#if defined(CERNLIB_QDEVZE)
      IF (NQDEVZ.GE.7)   WRITE (IQLOG,9842) KLA,KLE
 9842 FORMAT (16X,' KLA/KLE=',2I10)
#endif
#if defined(CERNLIB_QDEBUG)

      DO 47  JSTO=1,NQSTOR+1
      IF (NQALLO(JSTO).NE.0)       GO TO 47
      JT  = NQOFFT(JSTO)
      JS  = NQOFFS(JSTO)
      JSA = JS  - IQTABV(JT+2) + 1
      JSE = JS  + LQSTA(JT+21) + 1
      JTA = JT  + LQBTIS       + 1
      JTE = JTA + NQTSYS

#endif
#if defined(CERNLIB_QDEVZE)
      IF (NQDEVZ.GE.7)   WRITE (IQLOG,9843) JTA,JTE,  JSA,JSE
 9843 FORMAT (16X,' JTA/JTE=',2I10,'  JSA/JSE=',2I10)
#endif
#if defined(CERNLIB_QDEBUG)

      IF (KLE.GT.JTA .AND. KLA.LT.JTE)    GO TO 92
      IF (KLE.GT.JSA .AND. KLA.LT.JSE)    GO TO 93

C--                Check overlap with existing link areas

      L = JS+ LQSYSS(JT+1)
      N = IQ(L+1)
      IF (N.LT.12)                 GO TO 47

      DO 44  J=12,N,5
      JLA = JS + IQ(L+J)
      JLE = JS + IQ(L+J+1)

#endif
#if defined(CERNLIB_QDEVZE)
      IF (NQDEVZ.GE.7)   WRITE (IQLOG,9844) JLA,JLE
 9844 FORMAT (16X,' JLA/JLE=',2I10)
#endif
#if defined(CERNLIB_QDEBUG)

      IF (KLE.GT.JLA .AND. KLA.LT.JLE)    GO TO 94
   44 CONTINUE
   47 CONTINUE
#endif

C--                Success, register new link area

      LAREA(2) = NWTAB
      IQ(KQS+LSYS+1) = NWTAB + 5
      GO TO 19

C------            Error conditions

   94 NQCASE = 1
      NQFATA = 4
      IQUEST(21) = IQ(L+J+3)
      IQUEST(22) = IQ(L+J+4)
      IQUEST(23) = JLA + LQSTOR
      IQUEST(24) = LAREA(2)

   93 NQCASE = NQCASE + 1
   92 NQCASE = NQCASE + 1
      NQFATA = NQFATA + 3
      IQUEST(18) = JSTO - 1
      IQUEST(19) = NQPNAM(JT+1)
      IQUEST(20) = NQPNAM(JT+2)

   91 NQCASE = NQCASE + 1
      NQFATA = NQFATA + 7
      IQUEST(11) = NAME(1)
      IQUEST(12) = NAME(2)
      IQUEST(13) = LOCAR + LQSTOR
      IQUEST(14) = LOCR  + LQSTOR
      IQUEST(15) = LOCRL + LQSTOR
      IQUEST(16) = NSM2
      IQUEST(17) = NLM2
#include "zebra/qtofatal.inc"
      END
*      ==================================================
#include "zebra/qcardl.inc"
Commit	Line	Data
fe4da5cc	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) 4LQSTOR, 4LQATAB, 4LQBTIS, 4KLA
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"