[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / qutil / zshunt.F

*
* $Id$
*
* $Log$
* Revision 1.2  1996/04/18 16:13:43  mclareni
* Incorporate changes from J.Zoll for version 3.77
*
* Revision 1.1.1.1  1996/03/06 10:47:15  mclareni
* Zebra
*
*
#include "zebra/pilot.h"
      SUBROUTINE ZSHUNT (IXSTOR,LSHP,LSUPP,JBIASP,IFLAGP)

C-    RE-CONNECT BANK OR LINEAR D/S, USER CALLED

#include "zebra/zunit.inc"
#include "zebra/mqsys.inc"
#include "zebra/mzcn.inc"
C--------------    END CDE                             --------------
      DIMENSION    LSHP(9),LSUPP(9),JBIASP(9),IFLAGP(9)
#if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
      DIMENSION    NAMESR(2)
      DATA  NAMESR / 4HZSHU, 4HNT   /
#endif
#if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
      DATA  NAMESR / 6HZSHUNT /
#endif
#if !defined(CERNLIB_QTRHOLL)
      CHARACTER    NAMESR*8
      PARAMETER   (NAMESR = 'ZSHUNT  ')
#endif

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

#include "zebra/qtraceq.inc"

      LSH = LSHP(1)
      IF (LSH.EQ.0)                GO TO 999
      LSUP  = LSUPP(1)
      JBIAS = JBIASP(1)
      IFLAG = IFLAGP(1)

#include "zebra/qstore.inc"

#if defined(CERNLIB_QDEBUG)
      CALL MZCHLS (-7,LSH)
      IF (IQFOUL.NE.0)             GO TO 91
#endif
#if defined(CERNLIB_QDEBPRI)
      IF (NQLOGL.GE.2)  THEN
          IF (JBIAS.GE.2)  LSUP=0
          WRITE (IQLOG,9011) JQSTOR,LSH,LSUP,JBIAS,IFLAG,IQID
        ENDIF
 9011 FORMAT (' ZSHUNT-  Store',I3,' LSH/LSUP/JBIAS/IFLAG='
     F,2I9,1X,I6,1X,I3,' IDH= ',A4)
#endif

C----              LINKS AT EXIT POINT

      KEX  = LQ(KQS+LSH+2)
      LNEX = LQ(KQS+LSH)

C----              LINKS AT INSERTION POINT

      LPRE = 0
      IF   (JBIAS-1)         21, 25, 28
   21 CONTINUE
#if defined(CERNLIB_QDEBUG)
      CALL MZCHLS (-7,LSUP)
      IF (IQFOUL.NE.0)             GO TO 92
      IF (IQNS+JBIAS.LT.0)         GO TO 93
#endif
      KIN  = LSUP + JBIAS
      LNIN = LQ(KQS+KIN)
      LUP  = LSUP
      IF (JBIAS.NE.0)              GO TO 29
      LPRE = LUP
      LUP  = LQ(KQS+LUP+1)
      GO TO 29

   25 LNIN = LSUP
      IF (LNIN.EQ.0)               GO TO 26
#if defined(CERNLIB_QDEBUG)
      CALL MZCHLS (-7,LSUP)
      IF (IQFOUL.NE.0)             GO TO 92
#endif
      KIN  = LQ(KQS+LNIN+2)
      LUP  = LQ(KQS+LNIN+1)
      GO TO 29

   26 KIN  = LOCF(LSUPP(1)) - LQSTOR
      LUP  = 0
      GO TO 29

   28 KIN  = 0
      LNIN = 0
      LUP  = 0
      IF (KEX.EQ.0)                GO TO 51

C--                CHECK INSERT POINT = EXIT POINT

   29 IF (KIN.EQ.KEX)              GO TO 999

C--                CHECK LINEAR STRUCTURE CONTAINED

#if defined(CERNLIB_QDEBUG)
      L = MAX  (LNIN,LPRE)
      IF (L.EQ.0)                  GO TO 51

      IF (L.GE.LQEND(KQT+20))         GO TO 94
      IF (L.GE.LQEND(KQT+JQDVLL))     GO TO 43
      JQDIVI = 2
      IF (L.GE.LQEND(KQT+2))          GO TO 44
      IF (L.GE.LQSTA(KQT+2))          GO TO 45
      JQDIVI = 1
      GO TO 45

   43 JQDIVI = JQDVSY - 1
   44 JQDIVI = JQDIVI + 1
      IF (L.GE.LQEND(KQT+JQDIVI))     GO TO 44

   45 IF (LSH.LT.LQSTA(KQT+JQDIVI))   GO TO 94
      IF (LSH.GE.LQEND(KQT+JQDIVI))   GO TO 94
#endif

C----              SHUNT LINEAR STRUCTURE

   51 IF (LNEX.EQ.0)               GO TO 58
      IF (IFLAG.EQ.0)              GO TO 57
#if defined(CERNLIB_QDEBUG)
      L  = LSH
   53 CALL MZCHLS (-7,LNEX)
      IF (IQFOUL.NE.0)             GO TO 95
      L  = LNEX
      LNEX = LQ(KQS+LNEX)
      IF (LNEX.NE.0)               GO TO 53
#endif
      LNEX = LSH
   55 LEND = LNEX
      LQ(KQS+LEND+1) = LUP
      LNEX = LQ(KQS+LEND)
      IF (LNEX.NE.0)               GO TO 55
      GO TO 71

C----              SHUNT SINGLE BANK

   57 CONTINUE
#if defined(CERNLIB_QDEBUG)
      L  = LSH
      CALL MZCHLS (-7,LNEX)
      IF (IQFOUL.NE.0)             GO TO 95
#endif
   58 LEND = LSH
      LQ(KQS+LSH+1) = LUP

C----              CONNECTIONS

C--                BRIDGE OLD POSITION

   71 IF (KEX .NE.0)  LQ(KQS+KEX) = LNEX
      IF (LNEX.NE.0)  LQ(KQS+LNEX+2) = KEX

C--                CONNECT START

      IF (KIN.NE.0)  THEN
          LQ(KQS+KIN) = LSH
        ELSE
          LSUPP(1) = LSH
        ENDIF
      LQ(KQS+LSH+2) = KIN

C--                CONNECT END

      LQ(KQS+LEND) = LNIN
      IF (LNIN.NE.0)  LQ(KQS+LNIN+2) = LEND

#include "zebra/qtrace99.inc"
      RETURN

C------            ERROR CONDITIONS

#if defined(CERNLIB_QDEBUG)
   95 NQCASE = 1
      NQFATA = 1
      IQUEST(16) = LNEX
   94 NQCASE = NQCASE + 1
      NQFATA = NQFATA + 1
      IQUEST(15) = L
   93 NQCASE = NQCASE + 1
   92 NQCASE = NQCASE + 1
#endif
   91 NQCASE = NQCASE + 1
      NQFATA = NQFATA + 4
      IQUEST(11) = LSH
      IQUEST(12) = LSUP
      IQUEST(13) = JBIAS
      IQUEST(14) = IFLAG
#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:13:43 mclareni
	6	* Incorporate changes from J.Zoll for version 3.77
	7	*
	8	* Revision 1.1.1.1 1996/03/06 10:47:15 mclareni
	9	* Zebra
	10	*
	11	*
	12	#include "zebra/pilot.h"
	13	SUBROUTINE ZSHUNT (IXSTOR,LSHP,LSUPP,JBIASP,IFLAGP)
	14
	15	C- RE-CONNECT BANK OR LINEAR D/S, USER CALLED
	16
	17	#include "zebra/zunit.inc"
	18	#include "zebra/mqsys.inc"
	19	#include "zebra/mzcn.inc"
	20	C-------------- END CDE --------------
	21	DIMENSION LSHP(9),LSUPP(9),JBIASP(9),IFLAGP(9)
	22	#if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
	23	DIMENSION NAMESR(2)
	24	DATA NAMESR / 4HZSHU, 4HNT /
	25	#endif
	26	#if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
	27	DATA NAMESR / 6HZSHUNT /
	28	#endif
	29	#if !defined(CERNLIB_QTRHOLL)
	30	CHARACTER NAMESR*8
	31	PARAMETER (NAMESR = 'ZSHUNT ')
	32	#endif
	33
	34	#include "zebra/q_jbyt.inc"
	35	#include "zebra/q_locf.inc"
	36
	37	#include "zebra/qtraceq.inc"
	38
	39	LSH = LSHP(1)
	40	IF (LSH.EQ.0) GO TO 999
	41	LSUP = LSUPP(1)
	42	JBIAS = JBIASP(1)
	43	IFLAG = IFLAGP(1)
	44
	45	#include "zebra/qstore.inc"
	46
	47	#if defined(CERNLIB_QDEBUG)
	48	CALL MZCHLS (-7,LSH)
	49	IF (IQFOUL.NE.0) GO TO 91
	50	#endif
	51	#if defined(CERNLIB_QDEBPRI)
	52	IF (NQLOGL.GE.2) THEN
	53	IF (JBIAS.GE.2) LSUP=0
	54	WRITE (IQLOG,9011) JQSTOR,LSH,LSUP,JBIAS,IFLAG,IQID
	55	ENDIF
	56	9011 FORMAT (' ZSHUNT- Store',I3,' LSH/LSUP/JBIAS/IFLAG='
	57	F,2I9,1X,I6,1X,I3,' IDH= ',A4)
	58	#endif
	59
	60	C---- LINKS AT EXIT POINT
	61
	62	KEX = LQ(KQS+LSH+2)
	63	LNEX = LQ(KQS+LSH)
	64
65	C---- LINKS AT INSERTION POINT
66
67	LPRE = 0
68	IF (JBIAS-1) 21, 25, 28
69	21 CONTINUE
70	#if defined(CERNLIB_QDEBUG)
71	CALL MZCHLS (-7,LSUP)
72	IF (IQFOUL.NE.0) GO TO 92
73	IF (IQNS+JBIAS.LT.0) GO TO 93
74	#endif
75	KIN = LSUP + JBIAS
76	LNIN = LQ(KQS+KIN)
77	LUP = LSUP
78	IF (JBIAS.NE.0) GO TO 29
79	LPRE = LUP
80	LUP = LQ(KQS+LUP+1)
81	GO TO 29
82
83	25 LNIN = LSUP
84	IF (LNIN.EQ.0) GO TO 26
85	#if defined(CERNLIB_QDEBUG)
86	CALL MZCHLS (-7,LSUP)
87	IF (IQFOUL.NE.0) GO TO 92
88	#endif
89	KIN = LQ(KQS+LNIN+2)
90	LUP = LQ(KQS+LNIN+1)
91	GO TO 29
92
93	26 KIN = LOCF(LSUPP(1)) - LQSTOR
94	LUP = 0
95	GO TO 29
96
97	28 KIN = 0
98	LNIN = 0
99	LUP = 0
100	IF (KEX.EQ.0) GO TO 51
101
102	C-- CHECK INSERT POINT = EXIT POINT
103
104	29 IF (KIN.EQ.KEX) GO TO 999
105
106	C-- CHECK LINEAR STRUCTURE CONTAINED
107
108	#if defined(CERNLIB_QDEBUG)
109	L = MAX (LNIN,LPRE)
110	IF (L.EQ.0) GO TO 51
111
112	IF (L.GE.LQEND(KQT+20)) GO TO 94
113	IF (L.GE.LQEND(KQT+JQDVLL)) GO TO 43
114	JQDIVI = 2
115	IF (L.GE.LQEND(KQT+2)) GO TO 44
116	IF (L.GE.LQSTA(KQT+2)) GO TO 45
117	JQDIVI = 1
118	GO TO 45
119
120	43 JQDIVI = JQDVSY - 1
121	44 JQDIVI = JQDIVI + 1
122	IF (L.GE.LQEND(KQT+JQDIVI)) GO TO 44
123
124	45 IF (LSH.LT.LQSTA(KQT+JQDIVI)) GO TO 94
125	IF (LSH.GE.LQEND(KQT+JQDIVI)) GO TO 94
126	#endif
127
128	C---- SHUNT LINEAR STRUCTURE
129
130	51 IF (LNEX.EQ.0) GO TO 58
131	IF (IFLAG.EQ.0) GO TO 57
132	#if defined(CERNLIB_QDEBUG)
133	L = LSH
134	53 CALL MZCHLS (-7,LNEX)
135	IF (IQFOUL.NE.0) GO TO 95
136	L = LNEX
137	LNEX = LQ(KQS+LNEX)
138	IF (LNEX.NE.0) GO TO 53
139	#endif
140	LNEX = LSH
141	55 LEND = LNEX
142	LQ(KQS+LEND+1) = LUP
143	LNEX = LQ(KQS+LEND)
144	IF (LNEX.NE.0) GO TO 55
145	GO TO 71
146
147	C---- SHUNT SINGLE BANK
148
149	57 CONTINUE
150	#if defined(CERNLIB_QDEBUG)
151	L = LSH
152	CALL MZCHLS (-7,LNEX)
153	IF (IQFOUL.NE.0) GO TO 95
154	#endif
155	58 LEND = LSH
156	LQ(KQS+LSH+1) = LUP
157
158	C---- CONNECTIONS
159
160	C-- BRIDGE OLD POSITION
161
162	71 IF (KEX .NE.0) LQ(KQS+KEX) = LNEX
163	IF (LNEX.NE.0) LQ(KQS+LNEX+2) = KEX
164
165	C-- CONNECT START
166
167	IF (KIN.NE.0) THEN
168	LQ(KQS+KIN) = LSH
169	ELSE
170	LSUPP(1) = LSH
171	ENDIF
172	LQ(KQS+LSH+2) = KIN
173
174	C-- CONNECT END
175
176	LQ(KQS+LEND) = LNIN
177	IF (LNIN.NE.0) LQ(KQS+LNIN+2) = LEND
178
179	#include "zebra/qtrace99.inc"
180	RETURN
181
182	C------ ERROR CONDITIONS
183
184	#if defined(CERNLIB_QDEBUG)
185	95 NQCASE = 1
186	NQFATA = 1
187	IQUEST(16) = LNEX
188	94 NQCASE = NQCASE + 1
189	NQFATA = NQFATA + 1
190	IQUEST(15) = L
191	93 NQCASE = NQCASE + 1
192	92 NQCASE = NQCASE + 1
193	#endif
194	91 NQCASE = NQCASE + 1
195	NQFATA = NQFATA + 4
196	IQUEST(11) = LSH
197	IQUEST(12) = LSUP
198	IQUEST(13) = JBIAS
199	IQUEST(14) = IFLAG
200	#include "zebra/qtofatal.inc"
201	END
202	* ==================================================
203	#include "zebra/qcardl.inc"