Changes needed by ICC/IFC compiler (Intel)
[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / jz91 / jzin.F
CommitLineData
fe4da5cc 1*
2* $Id$
3*
4* $Log$
5* Revision 1.3 1996/04/24 17:26:30 mclareni
6* Extend the include file cleanup to dzebra, rz and tq, and also add
7* dependencies in some cases.
8*
9* Revision 1.2 1996/04/18 16:11:05 mclareni
10* Incorporate changes from J.Zoll for version 3.77
11*
12* Revision 1.1.1.1 1996/03/06 10:47:17 mclareni
13* Zebra
14*
15*
16#include "zebra/pilot.h"
17 SUBROUTINE JZIN (CHPA1,IPA2,IPA3,IPA4)
18
19C- Processor down transfer
20
21C- CHPA1 processor ID in A4
22C- IPA2 = 0 no further down transfer
23C- = 1 yes further down transfer
24C- IPA3 NAN = number of processor constants
25C- IPA4 extra features
26C- IPA4(2) NCR = number of conditions to be recorded
27C- IPA4(3) NLS = number of wsp links to be saved
28C- IPA4(4) NDS = number of wsp data words to be saved
29
30#include "zebra/zstate.inc"
31#include "zebra/zunit.inc"
32#include "zebra/zvfaut.inc"
33#include "zebra/mqsys.inc"
34#include "zebra/jzuc.inc"
35#include "zebra/jzc.inc"
36C-------------- END CDE ----------------- ------
37 DIMENSION IPA2(7),IPA3(7),IPA4(7)
38 CHARACTER CHPA1*4
39#if defined(CERNLIB_A4)
40 CHARACTER CHIAM*4
41#endif
42#if defined(CERNLIB_A8)
43 CHARACTER CHIAM*8
44#endif
45#if defined(CERNLIB_EQUHOLCH)
46 EQUIVALENCE (CHIAM, IAMID)
47#endif
48
49 DIMENSION MMJZFO(5)
50 PARAMETER (MXREOD = 2097152)
51#if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
52 DIMENSION NAMESR(2)
53 DATA NAMESR / 4HJZIN, 4H /
54#endif
55#if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
56 DATA NAMESR / 6HJZIN /
57#endif
58#if !defined(CERNLIB_QTRHOLL)
59 CHARACTER NAMESR*8
60 PARAMETER (NAMESR = 'JZIN ')
61#endif
62 DATA MMJZFO / 4HJZFO, 0, 0, 1, 2 /
63
64#include "zebra/q_jbit.inc"
65
66#include "zebra/qtraceq.inc"
67#include "zebra/qstorjz.inc"
68#if defined(CERNLIB_QDEBUG)
69 IF (IQVSTA.NE.0) CALL ZVAUTX
70#endif
71
72 CHIAM = CHPA1
73#if !defined(CERNLIB_EQUHOLCH)
74 CALL UCTOH (CHIAM, IAMID,4,4)
75#endif
76 IAFLDW = IPA2(1)
77 MINIT = 7
78 IF (LQSV.EQ.0) GO TO 21
79
80C---- Remember present state
81
82 IQ(KQS+LQJZ+2*JQLEV+2) = NQLINK
83 IQ(KQS+LQJZ+2*JQLEV+3) = LQSTA(KQT+1)
84
85 N = IQ(KQS+LQSV+3)
86 IF (N.NE.0) CALL UCOPY (LQ(KQS+NQREF+1),LQ(KQS+LQSV-N-3),N)
87 N = IQ(KQS+LQSV+4)
88 IF (N.NE.0) THEN
89 L = LQAN + IQ(KQS+LQAN)
90 CALL UCOPY (LQ(KQS+NQLINK+1),IQ(KQS+L+1),N)
91 ENDIF
92
93#if defined(CERNLIB_JZTIME)
94#include "zebra/jztimin.inc"
95#endif
96
97C---- Find SV bank
98
99 21 L = LQ(KQS+LQJZ-4)
100 IF (L.EQ.0) GO TO 24
101 J = IUCOMP (IAMID,IQ(KQS+L+2),IQ(KQS+L+1))
102 IF (J.EQ.0) GO TO 24
103 LQSV = LQ(KQS+L-J)
104 GO TO 25
105
106 24 LQSV = LZFIND (IXSTJZ,LQ(KQS+LQJZ-3), IAMID,1)
107 IF (LQSV.EQ.0) GO TO 81
108 25 IQ(KQS+LQSV+2) = IQ(KQS+LQSV+2) + 1
109 LCD = LQSV + JQNACC
110 LQAN = LCD + IQ(KQS+LCD) + 1
111
112C-- Copy flags
113
114#if defined(CERNLIB_QDEBUG)
115 CALL VZERO (JQFLAG,JQMFLW)
116 L = LQAN + IQ(KQS+LQAN) + 1 + IQ(KQS+LQSV+4)
117 N = IQ(KQS+L)
118 IF (N.NE.0) CALL UCOPY (IQ(KQS+L+1),JQFLAG,N)
119
120 IF (JBIT(JQLLEV,9).NE.0) WRITE (IQLOG,9024) JQLEV,NQME(1),
121 + IQ(KQS+LQSV+1),IQ(KQS+LQSV+2)
122
123 9024 FORMAT (/' ======= JZIN level',I2,', "',A4,' down to "',A4,
124 FI8,'th entry')
125#endif
126
127 JQEALL = JQEALL + 1
128 IF (JQEALL.EQ.0) GO TO 71
129
130C---- Step level
131
132 31 NQME(1) = IQ(KQS+LQSV+1)
133 JQLEV = JQLEV + 1
134 IF (JQLEV.GT.JQMLEV) GO TO 91
135 J = LQJZ - JQLEV - 6
136 LQDW = LQ(KQS+J)
137 LQUP = LQ(KQS+J+1)
138 J = J - JQMLEV
139 LQ(KQS+J) = LQSV
140 IQUEST(1) = MINIT
141 IF (IAFLDW.NE.0) GO TO 37
142 LQDW = 0
143#include "zebra/qtrace99.inc"
144 RETURN
145
146C-- Clear the down call bank
147
148 37 IF (JQLEV.EQ.JQMLEV) GO TO 92
149 CALL VZERO (LQ(KQS+LQDW-JQCBNL),JQCBNL)
150 CALL VZERO (IQ(KQS+LQDW+1), JQCBND)
151 IQ(KQS+LQDW) = MSBYT (0, IQ(KQS+LQDW),1,18)
152 GO TO 999
153
154C---- Re-order SV structure every now and then
155
156 71 JQREOD = MIN (4*JQREOD,MXREOD)
157 JQEALL = -JQREOD
158 IF (JQREOD.GE.MXREOD) GO TO 31
159 L = LQ(KQS+LQJZ-3)
160 CALL ZTOPSY (IXSTJZ,L)
161 CALL ZSORTI (IXSTJZ,L,2)
162 CALL ZTOPSY (IXSTJZ,L)
163 NPR = NZBANK (IXSTJZ,L)
164 INC = 10
165
166 LFO = LQ(KQS+LQJZ-4)
167 IF (LFO.EQ.0) GO TO 72
168 IF (NPR.LE.IQ(KQS+LFO-1)) GO TO 74
169 CALL MZDROP (IXSTJZ,IQ(KQS+LFO), '.')
170 INC = 4
171
172 72 MMJZFO(2) = NPR + INC
173 MMJZFO(4) = MMJZFO(2) + 1
174 CALL MZLIFT (IXDVJZ,LFO,LQJZ,-4,MMJZFO,0)
175 JQREOD = 512
176 JQEALL = -JQREOD
177
178 74 IQ(KQS+LFO+1) = NPR
179 J = 0
180 L = LQJZ - 3
181 75 L = LQ(KQS+L)
182 IF (L.EQ.0) GO TO 31
183 J = J + 1
184 LQ(KQS+LFO-J) = L
185 IQ(KQS+LFO+J+1) = IQ(KQS+L+1)
186 GO TO 75
187
188C---- Processor not yet initialized
189
190 81 IANAN = IPA3(1)
191 IANCR = 10
192 IANLSV = 0
193 IANDSV = 0
194
195 N = IPA4(1)
196 IF (N.GE.0) THEN
197 N = MIN (N,3)
198 CALL UCOPY (IPA4(2),IANCR,N)
199 ENDIF
200 CALL JZLIFT
201 MINIT = IQUEST(1)
202 LQSV = IQUEST(2)
203
204 LFO = LQ(KQS+LQJZ-4)
205 IF (LFO.EQ.0) GO TO 25
206 NFO = IQ(KQS+LFO+1) + 1
207 IF (NFO.GE.IQ(KQS+LFO-1)) GO TO 25
208 LQ(KQS+LFO-NFO) = LQSV
209 IQ(KQS+LFO+NFO+1) = IAMID
210 IQ(KQS+LFO+1) = NFO
211 GO TO 25
212
213C---- JQMLEV exeeded
214
215 92 NQCASE = 1
216 91 NQCASE = NQCASE + 1
217 NQFATA = 3
218 IQUEST(11) = IAMID
219 IQUEST(12) = IAFLDW
220 IQUEST(13) = JQLEV
221#include "zebra/qtofatal.inc"
222 END
223* ==================================================
224#include "zebra/qcardl.inc"