Changes needed by ICC/IFC compiler (Intel)
[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / jz91 / jzinit.F
1 *
2 * $Id$
3 *
4 * $Log$
5 * Revision 1.2  1996/04/18 16:11:06  mclareni
6 * Incorporate changes from J.Zoll for version 3.77
7 *
8 * Revision 1.1.1.1  1996/03/06 10:47:16  mclareni
9 * Zebra
10 *
11 *
12 #include "zebra/pilot.h"
13       SUBROUTINE JZINIT (IXPARA,CHPA1,CHPA2,IPA3,IPA4,IPA5,IPA6)
14
15 C-    Initialize JZ91 package
16
17
18 #include "zebra/zstate.inc"
19 #include "zebra/zunit.inc"
20 #include "zebra/mqsys.inc"
21 #include "zebra/eqlqt.inc"
22 #include "zebra/jzuc.inc"
23 #include "zebra/jzc.inc"
24 C--------------    END CDE                             -----------------  ------
25       DIMENSION    IPA3(7),IPA4(7),IPA5(7),IPA6(7)
26       CHARACTER    CHPA1*(*), CHPA2*(*)
27 #if defined(CERNLIB_A4)
28       CHARACTER    CHIAM*4
29 #endif
30 #if defined(CERNLIB_A8)
31       CHARACTER    CHIAM*8
32 #endif
33 #if defined(CERNLIB_EQUHOLCH)
34       EQUIVALENCE (CHIAM, NQME(1))
35 #endif
36
37       DIMENSION    INIT(4),          MEXTR(4)
38       EQUIVALENCE (INIT(1),JQTIME), (NACCE,NQME(6))
39       DIMENSION    MMJZ91(5), MMCALL(5)
40 #if defined(CERNLIB_QDEBUG)
41       DIMENSION    MMFL(5)
42 #endif
43 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
44       DIMENSION    NAMESR(2)
45       DATA  NAMESR / 4HJZIN, 4HIT   /
46 #endif
47 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
48       DATA  NAMESR / 6HJZINIT /
49 #endif
50 #if !defined(CERNLIB_QTRHOLL)
51       CHARACTER    NAMESR*8
52       PARAMETER   (NAMESR = 'JZINIT  ')
53 #endif
54 #if defined(CERNLIB_QDEBUG)
55
56       DATA  MEND   /4HEND /
57       DATA  MMFL   /4HJZFL,  0,  0, -7, 2 /
58 #endif
59       DATA  MMJZ91 /4HJZ91, -7, -7, -7, 2 /
60       DATA  MMCALL /4HJZCA, -7,  0, -7, 0 /
61
62       DATA    MJQAN/4HJZAN/, MJQFL/4HJZFL/
63
64 #include "zebra/q_shiftl.inc"
65
66 #include "zebra/qtraceq.inc"
67
68       IF (JQLEV.NE.-1)       CALL ZFATAM ('re-init of JZ91.')
69       CALL VZERO (JQTIME,16)
70
71       CALL MZSDIV (IXPARA,-7)
72       JQSTJZ = JQSTOR
73       IXSTJZ = ISHFTL(JQSTJZ,26)
74
75       JQMLEV = IPA3(1)
76       JQCBNL = IPA4(1)
77       JQCBND = IPA5(1)
78
79       CALL UOPTC (CHPA2,'TQE',IQUEST)
80       JQTIME = IQUEST(1)
81       JQLLEV = 2
82       IF (IQUEST(2).NE.0)  JQLLEV = 0
83       IF (IQUEST(3).NE.0)  JQLLEV = 1
84
85       CHIAM = CHPA1
86 #if !defined(CERNLIB_EQUHOLCH)
87       CALL UCTOH (CHIAM, NQME(1),4,4)
88 #endif
89       NQME(2) = 10
90       NQME(3) = 10
91
92       N = IPA6(1)
93       IF (N.GE.0)  THEN
94           N =  MIN (N,5)
95           CALL UCOPY (IPA6(2),NQME(2),N)
96         ENDIF
97
98       IF (JQLLEV.GE.2)  WRITE (IQLOG,9001) JQSTJZ,INIT
99  9001 FORMAT (/' JZINIT.  JZ91 in store',I2,
100      F', IFTIME,MAXLEV,NL,ND =',7I6)
101
102       MMCALL(2) = JQCBNL
103       MMCALL(4) = JQCBND
104       JQNACC   = 9 + NACCE
105       MEXTR(1) = 3
106       MEXTR(2) = NQME(3)
107       MEXTR(3) = NQME(4)
108       MEXTR(4) = NQME(5)
109
110 C--                Lift division JZ91
111
112       NWINT = 1000
113       NWMAX = LQSTA(KQT+21) / 2
114       CALL MZDIV  (IXSTJZ,IXDVJZ,'JZ91',NWINT,NWMAX,'ML')
115       CALL MZLINK (IXSTJZ,'JZ91',LQJZ,LQUP,LQAN)
116
117 C----              Lift main bank
118
119       MMJZ91(2) = 2*JQMLEV + 6
120       MMJZ91(3) =   JQMLEV + 5
121       MMJZ91(4) = 2*JQMLEV + 2
122       CALL MZLIFT (IXDVJZ,L,LQJZ,1,MMJZ91,0)
123       IQ(KQS+LQJZ+1) = NACCE
124
125 C----              Lift the call banks
126
127       DO 24 J=1,JQMLEV
128       CALL MZLIFT (IXDVJZ,L,LQJZ,-J-5,MMCALL,0)
129    24 CONTINUE
130
131 C----              Collect all JQAN titles
132
133       CALL TZINQ (IXSTJZ,IXDVTT,LQAN,1)
134       IF (LQAN.EQ.0)               GO TO 49
135       CALL MZXREF (IXDVJZ,IXDVTT,'A')
136       GO TO 33
137
138    32 LQAN = LQ(KQS+LQAN)
139    33 IF (LQAN.EQ.0)               GO TO 39
140       IF (IQ(KQS+LQAN-4).NE.MJQAN)    GO TO 32
141
142       L = LZFIND (IXSTJZ,LQ(KQS+LQJZ-1), IQ(KQS+LQAN+1),1)
143       IF (L.NE.0)                  GO TO 34
144       L    = LQAN
145       LQAN = LQ(KQS+LQAN)
146       CALL ZSHUNT (IXSTJZ,L,LQJZ,-1,0)
147       GO TO 33
148
149    34 CALL MZDROP (IXSTJZ,LQAN, '.')
150       GO TO 32
151
152    39 CALL ZTOPSY (IXSTJZ,LQ(KQS+LQJZ-1))
153
154 C----              Digest all JQFL titles
155
156       LQAN = LQT(KQT+1)
157       GO TO 43
158
159    42 LQAN = LQ(KQS+LQAN)
160    43 IF (LQAN.EQ.0)               GO TO 49
161       IF (IQ(KQS+LQAN-4).NE.MJQFL)    GO TO 42
162
163 #if defined(CERNLIB_QDEBUG)
164       JNEXT = 1
165       JMAX  = IQ(KQS+LQAN-1)
166
167    44 IF (JNEXT.GT.JMAX)           GO TO 47
168       JID   = JNEXT
169       JEND  = IUFIND (MEND,IQ(KQS+LQAN+1),JID+1,JMAX)
170       JNEXT = JEND + 1
171       ID = IQ(KQS+LQAN+JID)
172       IF (LZFIND(IXSTJZ,LQ(KQS+LQJZ-2),ID,1).NE.0)   GO TO 44
173
174       IF (JID .NE.1)               GO TO 45
175       IF (JEND.LE.JMAX)            GO TO 45
176       L    = LQAN
177       LQAN = LQ(KQS+LQAN)
178       CALL ZSHUNT (IXSTJZ,L, LQJZ,-2,0)
179       GO TO 33
180
181    45 MMFL(4) = MIN (JEND-JID,JQMFLW+1)
182       CALL MZLIFT (IXDVTT,L,LQJZ,-2,MMFL,-1)
183       CALL UCOPY (IQ(KQS+LQAN+JID),IQ(KQS+L+1),MMFL(4))
184       GO TO 44
185
186 #endif
187    47 CALL MZDROP (IXSTJZ,LQAN, '.')
188       GO TO 42
189
190    49 CONTINUE
191
192 C----              Lift the root level
193
194 #if defined(CERNLIB_JZTIME)
195 #include "zebra/jztimed.inc"
196 #endif
197
198       JQREOD = 512
199       JQEALL = -JQREOD
200
201       CALL JZIN (CHIAM,1,NQME(2),MEXTR)
202
203 #include "zebra/qtrace99.inc"
204       RETURN
205       END
206 *      ==================================================
207 #include "zebra/qcardl.inc"