[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / jz91 / jzin.F

*
* $Id$
*
* $Log$
* Revision 1.3  1996/04/24 17:26:30  mclareni
* Extend the include file cleanup to dzebra, rz and tq, and also add
* dependencies in some cases.
*
* Revision 1.2  1996/04/18 16:11:05  mclareni
* Incorporate changes from J.Zoll for version 3.77
*
* Revision 1.1.1.1  1996/03/06 10:47:17  mclareni
* Zebra
*
*
#include "zebra/pilot.h"
      SUBROUTINE JZIN (CHPA1,IPA2,IPA3,IPA4)

C-    Processor down transfer

C-     CHPA1  processor ID in A4
C-      IPA2  = 0  no further down transfer
C-            = 1 yes further down transfer
C-      IPA3  NAN = number of processor constants
C-      IPA4  extra features
C-   IPA4(2)  NCR = number of conditions to be recorded
C-   IPA4(3)  NLS = number of wsp links to be saved
C-   IPA4(4)  NDS = number of wsp data words to be saved

#include "zebra/zstate.inc"
#include "zebra/zunit.inc"
#include "zebra/zvfaut.inc"
#include "zebra/mqsys.inc"
#include "zebra/jzuc.inc"
#include "zebra/jzc.inc"
C--------------    END CDE                             -----------------  ------
      DIMENSION    IPA2(7),IPA3(7),IPA4(7)
      CHARACTER    CHPA1*4
#if defined(CERNLIB_A4)
      CHARACTER    CHIAM*4
#endif
#if defined(CERNLIB_A8)
      CHARACTER    CHIAM*8
#endif
#if defined(CERNLIB_EQUHOLCH)
      EQUIVALENCE (CHIAM, IAMID)
#endif

      DIMENSION    MMJZFO(5)
      PARAMETER   (MXREOD = 2097152)
#if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
      DIMENSION    NAMESR(2)
      DATA  NAMESR / 4HJZIN, 4H     /
#endif
#if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
      DATA  NAMESR / 6HJZIN   /
#endif
#if !defined(CERNLIB_QTRHOLL)
      CHARACTER    NAMESR*8
      PARAMETER   (NAMESR = 'JZIN    ')
#endif
      DATA  MMJZFO / 4HJZFO, 0, 0, 1, 2 /

#include "zebra/q_jbit.inc"

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

      CHIAM  = CHPA1
#if !defined(CERNLIB_EQUHOLCH)
      CALL UCTOH (CHIAM, IAMID,4,4)
#endif
      IAFLDW = IPA2(1)
      MINIT  = 7
      IF (LQSV.EQ.0)               GO TO 21

C----              Remember present state

      IQ(KQS+LQJZ+2*JQLEV+2) = NQLINK
      IQ(KQS+LQJZ+2*JQLEV+3) = LQSTA(KQT+1)

      N = IQ(KQS+LQSV+3)
      IF (N.NE.0) CALL UCOPY (LQ(KQS+NQREF+1),LQ(KQS+LQSV-N-3),N)
      N = IQ(KQS+LQSV+4)
      IF (N.NE.0)  THEN
          L = LQAN + IQ(KQS+LQAN)
          CALL UCOPY (LQ(KQS+NQLINK+1),IQ(KQS+L+1),N)
        ENDIF

#if defined(CERNLIB_JZTIME)
#include "zebra/jztimin.inc"
#endif

C----              Find SV bank

   21 L = LQ(KQS+LQJZ-4)
      IF (L.EQ.0)                  GO TO 24
      J = IUCOMP (IAMID,IQ(KQS+L+2),IQ(KQS+L+1))
      IF (J.EQ.0)                  GO TO 24
      LQSV = LQ(KQS+L-J)
      GO TO 25

   24 LQSV   = LZFIND (IXSTJZ,LQ(KQS+LQJZ-3), IAMID,1)
      IF (LQSV.EQ.0)               GO TO 81
   25 IQ(KQS+LQSV+2) = IQ(KQS+LQSV+2) + 1
      LCD  = LQSV + JQNACC
      LQAN = LCD + IQ(KQS+LCD) + 1

C--                Copy flags

#if defined(CERNLIB_QDEBUG)
      CALL VZERO (JQFLAG,JQMFLW)
      L = LQAN + IQ(KQS+LQAN) + 1 + IQ(KQS+LQSV+4)
      N = IQ(KQS+L)
      IF (N.NE.0)  CALL UCOPY (IQ(KQS+L+1),JQFLAG,N)

      IF (JBIT(JQLLEV,9).NE.0)  WRITE (IQLOG,9024) JQLEV,NQME(1),
     +                          IQ(KQS+LQSV+1),IQ(KQS+LQSV+2)

 9024 FORMAT (/' =======  JZIN   level',I2,', "',A4,' down to "',A4,
     FI8,'th entry')
#endif

      JQEALL = JQEALL + 1
      IF (JQEALL.EQ.0)             GO TO 71

C----              Step level

   31 NQME(1) = IQ(KQS+LQSV+1)
      JQLEV   = JQLEV + 1
      IF (JQLEV.GT.JQMLEV)         GO TO 91
      J     = LQJZ - JQLEV - 6
      LQDW  = LQ(KQS+J)
      LQUP  = LQ(KQS+J+1)
      J     = J - JQMLEV
      LQ(KQS+J) = LQSV
      IQUEST(1) = MINIT
      IF (IAFLDW.NE.0)             GO TO 37
      LQDW = 0
#include "zebra/qtrace99.inc"
      RETURN

C--                Clear the down call bank

   37 IF (JQLEV.EQ.JQMLEV)         GO TO 92
      CALL VZERO (LQ(KQS+LQDW-JQCBNL),JQCBNL)
      CALL VZERO (IQ(KQS+LQDW+1),     JQCBND)
      IQ(KQS+LQDW) = MSBYT (0, IQ(KQS+LQDW),1,18)
      GO TO 999

C----              Re-order SV structure every now and then

   71 JQREOD = MIN (4*JQREOD,MXREOD)
      JQEALL = -JQREOD
      IF (JQREOD.GE.MXREOD)        GO TO 31
      L = LQ(KQS+LQJZ-3)
      CALL ZTOPSY (IXSTJZ,L)
      CALL ZSORTI (IXSTJZ,L,2)
      CALL ZTOPSY (IXSTJZ,L)
      NPR  = NZBANK (IXSTJZ,L)
      INC  = 10

      LFO = LQ(KQS+LQJZ-4)
      IF (LFO.EQ.0)                GO TO 72
      IF (NPR.LE.IQ(KQS+LFO-1))       GO TO 74
      CALL MZDROP (IXSTJZ,IQ(KQS+LFO), '.')
      INC = 4

   72 MMJZFO(2) = NPR + INC
      MMJZFO(4) = MMJZFO(2) + 1
      CALL MZLIFT (IXDVJZ,LFO,LQJZ,-4,MMJZFO,0)
      JQREOD = 512
      JQEALL = -JQREOD

   74 IQ(KQS+LFO+1) = NPR
      J = 0
      L = LQJZ - 3
   75 L = LQ(KQS+L)
      IF (L.EQ.0)                  GO TO 31
      J = J + 1
      LQ(KQS+LFO-J)   = L
      IQ(KQS+LFO+J+1) = IQ(KQS+L+1)
      GO TO 75

C----              Processor not yet initialized

   81 IANAN = IPA3(1)
      IANCR = 10
      IANLSV = 0
      IANDSV = 0

      N = IPA4(1)
      IF (N.GE.0)  THEN
          N =  MIN (N,3)
          CALL UCOPY (IPA4(2),IANCR,N)
        ENDIF
      CALL JZLIFT
      MINIT = IQUEST(1)
      LQSV  = IQUEST(2)

      LFO = LQ(KQS+LQJZ-4)
      IF (LFO.EQ.0)                GO TO 25
      NFO = IQ(KQS+LFO+1) + 1
      IF (NFO.GE.IQ(KQS+LFO-1))       GO TO 25
      LQ(KQS+LFO-NFO)   = LQSV
      IQ(KQS+LFO+NFO+1) = IAMID
      IQ(KQS+LFO+1)     = NFO
      GO TO 25

C----              JQMLEV exeeded

   92 NQCASE = 1
   91 NQCASE = NQCASE + 1
      NQFATA = 3
      IQUEST(11) = IAMID
      IQUEST(12) = IAFLDW
      IQUEST(13) = JQLEV
#include "zebra/qtofatal.inc"
      END
*      ==================================================
#include "zebra/qcardl.inc"
Commit	Line	Data
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
	19	C- Processor down transfer
	20
	21	C- CHPA1 processor ID in A4
	22	C- IPA2 = 0 no further down transfer
	23	C- = 1 yes further down transfer
	24	C- IPA3 NAN = number of processor constants
	25	C- IPA4 extra features
	26	C- IPA4(2) NCR = number of conditions to be recorded
	27	C- IPA4(3) NLS = number of wsp links to be saved
	28	C- 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"
	36	C-------------- 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
80	C---- 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
97	C---- 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
112	C-- 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
130	C---- 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
146	C-- 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
154	C---- 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
188	C---- 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
213	C---- 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"