[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / mqs / mziocr.F

*
* $Id$
*
* $Log$
* Revision 1.2  1996/04/18 16:13:05  mclareni
* Incorporate changes from J.Zoll for version 3.77
*
* Revision 1.1.1.1  1996/03/06 10:47:22  mclareni
* Zebra
*
*
#include "zebra/pilot.h"
      SUBROUTINE MZIOCR (IOW)

C-    Crack I/O characteristic ready for use, system called

#include "zebra/quest.inc"
#include "zebra/mzioc.inc"
C--------------    END CDE                             --------------
      EQUIVALENCE (JIO,IQUEST(1))
      DIMENSION    IOW(9)
      DIMENSION    NBITVA(4), NBITVB(4), NBITVC(7)
#if defined(CERNLIB_QMVDS)
      SAVE         NBITVA, NBITVB, NBITVC
#endif
      DATA  NBITVA / 32,    16,   10,   8 /
      DATA  NBITVB / 29,    14,    9,   7 /
      DATA  NBITVC / 26,    11,    6,   4, 2, 1, 1 /

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


      NWFODN = 0
      JFOCUR = 0

      JTYPR  = IOW(1)
      IOW1   = JBYT (JTYPR,17,16)

C--                IMMEDIATE CHARACTERISTIC

      IF (IOW1.NE.0)               GO TO 21
      IF (JTYPR.GE.8)              GO TO 21
      MFO(1) = JTYPR
      MFO(2) = -1
      JFOEND = 2
      JFOREP = 2
      RETURN

C----              GENERAL

   21 JFOEND = 0
      JFOREP = 0
      JIO    = 1
      JTYPR  = JBYT (IOW1,1,3)
      JFLAG  = JBIT (IOW1,4)
      JCLASS = JBYT (IOW1,14,3)
      JFL12  = 0

      GO TO ( 101, 201, 301, 401, 501, 601, 991), JCLASS

C--                CLASS 0 : 'CT -T'

      JFL12 = JFLAG + 1
      JTYP  = JBYT (IOW1,5,3)
      IF (JTYP.NE.0)  THEN
          MFO(1) = JTYP
          MFO(2) = JBYT (IOW1,8,6)
          JFOEND = 2
        ENDIF

   24 IF (JTYPR.EQ.7)      GO TO 28
      MFO(JFOEND+1) = JTYPR
      MFO(JFOEND+2) = JFL12 - 2
      JFOEND = JFOEND + 2
      JFOREP = JFOEND
      RETURN

   28 JFOREP = JFOEND
      MFO(JFOEND+1) = 7
      MFO(JFOEND+2) = 0
      JFOEND = JFOEND + 2
      RETURN

C--                CLASS 1 OR 2 : 'CT ... CT -T'  OR  'CT ... CT *CT'

  101 CONTINUE
  201 JFL12 = JCLASS
      IF (JTYPR.NE.0)              GO TO 821
      JTYPR = JBYT (IOW1,5,3)
      JBT   = 8
      GO TO 831

C--                CLASS 3 : 'CT / *T'  OR  '/ CT *T'

  301 JTYP = JBYT (IOW1,5,3)
      IF (JTYP.NE.0)  THEN
          MFO(1) = JTYP
          MFO(2) = JBYT (IOW1,8,6)
          JFOEND = 2
          IF (JFLAG.EQ.0)  JFOREP = 2
        ENDIF

      MFO(JFOEND+1) = JTYPR
      MFO(JFOEND+2) = 0
      JFOEND = JFOEND + 2
      RETURN

C--                CLASS 4 :  'CT / CT CT CT' OR 'CT CT / CT CT'

  401 JFOREP = 2*(JFLAG+1)
      JFLAG  = 0

C--                CLASS 5 : '/ CT ... CT'

  501 IF (JTYPR.EQ.0)              GO TO 830
      MFO(1) = JTYPR
      JFOEND = 2
      GO TO 821

C--                CLASS 6 : 'CT ... CT / CT ... CT'

  601 JFOREP = 2*JBYT(IOW1,1,4)
      JFLAG  = 1

C----              COMMON UNPACKING FOR CLASSES 1, 2, 4, 5, 6

  821 JIO = 2
      DO  822  JBT=5,11,3
      JTYP = JBYT (IOW1,JBT,3)
      IF (JTYP.EQ.0)               GO TO 823
      MFO(JFOEND+1) = JTYP
  822 JFOEND = JFOEND + 2
  823 NGRU   = JFOEND/2

C--                UNPACK I/O WORD 2

      IF (JFLAG.EQ.0)  THEN
          NBT = NBITVA(NGRU)
        ELSE
          NBT = NBITVB(NGRU)
        ENDIF

      JFOEND = 0
      JBT    = 1
      IOWN   = IOW(2)
      DO  824  JL=1,NGRU
      MFO(JFOEND+2) = JBYT(IOWN,JBT,NBT)
      JFOEND = JFOEND + 2
  824 JBT    = JBT + NBT
      IF (JFLAG.EQ.0)              GO TO 839

C--                UNPACK I/O WORDS 3, 4, ...

  825 NGRU = JBYT(IOWN,30,3)
      IF (NGRU.EQ.0)               GO TO 839
      JIO  = JIO + 1
      IF (JIO.EQ.17)               GO TO 991
      IOWN = IOW(JIO)
      JBTT = 1
      JBTC = 3*NGRU + 1
      NBT  = NBITVC(NGRU)

      DO  826  JL=1,NGRU
      MFO(JFOEND+1) = JBYT (IOWN,JBTT,3)
      MFO(JFOEND+2) = JBYT (IOWN,JBTC,NBT)
      JBTT   = JBTT + 3
      JBTC   = JBTC + NBT
  826 JFOEND = JFOEND + 2
      GO TO 825

C----              SUB-CLASSES ZERO

  830 JBT = 5
  831 DO  834  JL=JBT,11,3
      JTYP = JBYT (IOW1,JL,3)
      IF (JTYP.EQ.0)               GO TO 839
      MFO(JFOEND+1) = JTYP
      MFO(JFOEND+2) = 0
  834 JFOEND = JFOEND + 2

  839 IF (JFL12.NE.0)              GO TO 24
      RETURN

C-------           TROUBLE

  991 IQUEST(1) = -1
      MFO(1) = 0
      MFO(2) = -1
      JFOEND = 2
      RETURN
      END
*      ==================================================
#include "zebra/qcardl.inc"
Commit	Line	Data
fe4da5cc	1	*
	2	* $Id$
	3	*
	4	* $Log$
	5	* Revision 1.2 1996/04/18 16:13:05 mclareni
	6	* Incorporate changes from J.Zoll for version 3.77
	7	*
	8	* Revision 1.1.1.1 1996/03/06 10:47:22 mclareni
	9	* Zebra
	10	*
	11	*
	12	#include "zebra/pilot.h"
	13	SUBROUTINE MZIOCR (IOW)
	14
	15	C- Crack I/O characteristic ready for use, system called
	16
	17	#include "zebra/quest.inc"
	18	#include "zebra/mzioc.inc"
	19	C-------------- END CDE --------------
	20	EQUIVALENCE (JIO,IQUEST(1))
	21	DIMENSION IOW(9)
	22	DIMENSION NBITVA(4), NBITVB(4), NBITVC(7)
	23	#if defined(CERNLIB_QMVDS)
	24	SAVE NBITVA, NBITVB, NBITVC
	25	#endif
	26	DATA NBITVA / 32, 16, 10, 8 /
	27	DATA NBITVB / 29, 14, 9, 7 /
	28	DATA NBITVC / 26, 11, 6, 4, 2, 1, 1 /
	29
	30	#include "zebra/q_jbit.inc"
	31	#include "zebra/q_jbyt.inc"
	32
	33
	34	NWFODN = 0
	35	JFOCUR = 0
	36
	37	JTYPR = IOW(1)
	38	IOW1 = JBYT (JTYPR,17,16)
	39
	40	C-- IMMEDIATE CHARACTERISTIC
	41
	42	IF (IOW1.NE.0) GO TO 21
	43	IF (JTYPR.GE.8) GO TO 21
	44	MFO(1) = JTYPR
	45	MFO(2) = -1
	46	JFOEND = 2
	47	JFOREP = 2
	48	RETURN
	49
	50	C---- GENERAL
	51
	52	21 JFOEND = 0
	53	JFOREP = 0
	54	JIO = 1
	55	JTYPR = JBYT (IOW1,1,3)
	56	JFLAG = JBIT (IOW1,4)
	57	JCLASS = JBYT (IOW1,14,3)
	58	JFL12 = 0
	59
	60	GO TO ( 101, 201, 301, 401, 501, 601, 991), JCLASS
	61
	62	C-- CLASS 0 : 'CT -T'
	63
	64	JFL12 = JFLAG + 1
65	JTYP = JBYT (IOW1,5,3)
66	IF (JTYP.NE.0) THEN
67	MFO(1) = JTYP
68	MFO(2) = JBYT (IOW1,8,6)
69	JFOEND = 2
70	ENDIF
71
72	24 IF (JTYPR.EQ.7) GO TO 28
73	MFO(JFOEND+1) = JTYPR
74	MFO(JFOEND+2) = JFL12 - 2
75	JFOEND = JFOEND + 2
76	JFOREP = JFOEND
77	RETURN
78
79	28 JFOREP = JFOEND
80	MFO(JFOEND+1) = 7
81	MFO(JFOEND+2) = 0
82	JFOEND = JFOEND + 2
83	RETURN
84
85	C-- CLASS 1 OR 2 : 'CT ... CT -T' OR 'CT ... CT *CT'
86
87	101 CONTINUE
88	201 JFL12 = JCLASS
89	IF (JTYPR.NE.0) GO TO 821
90	JTYPR = JBYT (IOW1,5,3)
91	JBT = 8
92	GO TO 831
93
94	C-- CLASS 3 : 'CT / T' OR '/ CT T'
95
96	301 JTYP = JBYT (IOW1,5,3)
97	IF (JTYP.NE.0) THEN
98	MFO(1) = JTYP
99	MFO(2) = JBYT (IOW1,8,6)
100	JFOEND = 2
101	IF (JFLAG.EQ.0) JFOREP = 2
102	ENDIF
103
104	MFO(JFOEND+1) = JTYPR
105	MFO(JFOEND+2) = 0
106	JFOEND = JFOEND + 2
107	RETURN
108
109	C-- CLASS 4 : 'CT / CT CT CT' OR 'CT CT / CT CT'
110
111	401 JFOREP = 2*(JFLAG+1)
112	JFLAG = 0
113
114	C-- CLASS 5 : '/ CT ... CT'
115
116	501 IF (JTYPR.EQ.0) GO TO 830
117	MFO(1) = JTYPR
118	JFOEND = 2
119	GO TO 821
120
121	C-- CLASS 6 : 'CT ... CT / CT ... CT'
122
123	601 JFOREP = 2*JBYT(IOW1,1,4)
124	JFLAG = 1
125
126	C---- COMMON UNPACKING FOR CLASSES 1, 2, 4, 5, 6
127
128	821 JIO = 2
129	DO 822 JBT=5,11,3
130	JTYP = JBYT (IOW1,JBT,3)
131	IF (JTYP.EQ.0) GO TO 823
132	MFO(JFOEND+1) = JTYP
133	822 JFOEND = JFOEND + 2
134	823 NGRU = JFOEND/2
135
136	C-- UNPACK I/O WORD 2
137
138	IF (JFLAG.EQ.0) THEN
139	NBT = NBITVA(NGRU)
140	ELSE
141	NBT = NBITVB(NGRU)
142	ENDIF
143
144	JFOEND = 0
145	JBT = 1
146	IOWN = IOW(2)
147	DO 824 JL=1,NGRU
148	MFO(JFOEND+2) = JBYT(IOWN,JBT,NBT)
149	JFOEND = JFOEND + 2
150	824 JBT = JBT + NBT
151	IF (JFLAG.EQ.0) GO TO 839
152
153	C-- UNPACK I/O WORDS 3, 4, ...
154
155	825 NGRU = JBYT(IOWN,30,3)
156	IF (NGRU.EQ.0) GO TO 839
157	JIO = JIO + 1
158	IF (JIO.EQ.17) GO TO 991
159	IOWN = IOW(JIO)
160	JBTT = 1
161	JBTC = 3*NGRU + 1
162	NBT = NBITVC(NGRU)
163
164	DO 826 JL=1,NGRU
165	MFO(JFOEND+1) = JBYT (IOWN,JBTT,3)
166	MFO(JFOEND+2) = JBYT (IOWN,JBTC,NBT)
167	JBTT = JBTT + 3
168	JBTC = JBTC + NBT
169	826 JFOEND = JFOEND + 2
170	GO TO 825
171
172	C---- SUB-CLASSES ZERO
173
174	830 JBT = 5
175	831 DO 834 JL=JBT,11,3
176	JTYP = JBYT (IOW1,JL,3)
177	IF (JTYP.EQ.0) GO TO 839
178	MFO(JFOEND+1) = JTYP
179	MFO(JFOEND+2) = 0
180	834 JFOEND = JFOEND + 2
181
182	839 IF (JFL12.NE.0) GO TO 24
183	RETURN
184
185	C------- TROUBLE
186
187	991 IQUEST(1) = -1
188	MFO(1) = 0
189	MFO(2) = -1
190	JFOEND = 2
191	RETURN
192	END
193	* ==================================================
194	#include "zebra/qcardl.inc"