]> git.uio.no Git - u/mrichter/AliRoot.git/blame - MINICERN/packlib/zebra/mqs/mzioch.F
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / mqs / mzioch.F
CommitLineData
fe4da5cc 1*
2* $Id$
3*
4* $Log$
5* Revision 1.2 1996/04/18 16:13:03 mclareni
6* Incorporate changes from J.Zoll for version 3.77
7*
8* Revision 1.1.1.1 1996/03/06 10:47:21 mclareni
9* Zebra
10*
11*
12#include "zebra/pilot.h"
13 SUBROUTINE MZIOCH (IODVEC,NWIOMP,CHFORM)
14
15C- Analyse I/O descriptor, user called, also from MZFORM / MZIOBK
16C- convert the descriptor CHFORM into the I/O characteristic
17C- stored into IODVEC of length NWIOMX
18
19#include "zebra/zkrakc.inc"
20#include "zebra/zstate.inc"
21#include "zebra/zunit.inc"
22#include "zebra/quest.inc"
23#include "zebra/mzca.inc"
24#include "zebra/zbcd.inc"
25C-------------- END CDE --------------
26 DIMENSION IODVEC(99), NWIOMP(9)
27 CHARACTER CHFORM*(*)
28
29 EQUIVALENCE (NGR,IQUEST(1)), (NGRU,IQUEST(2))
30
31 DIMENSION MU(99), MCE(99)
32 EQUIVALENCE (MU(1),IQHOLK(1)), (MCE(1),IQCETK(1))
33
34 DIMENSION NBITVA(4), NBITVB(4), NBITVC(7)
35 DIMENSION MXVALA(4), MXVALB(4), MXVALC(7)
36
37 DIMENSION ITAB(48), INV(10)
38
39#if defined(CERNLIB_QMVDS)
40 SAVE NBITVA, NBITVB, NBITVC
41 SAVE MXVALA, MXVALB, MXVALC
42 SAVE ITAB, INV
43#endif
44#if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
45 DIMENSION NAMESR(2)
46 DATA NAMESR / 4HMZIO, 4HCH /
47#endif
48#if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
49 DATA NAMESR / 6HMZIOCH /
50#endif
51#if !defined(CERNLIB_QTRHOLL)
52 CHARACTER NAMESR*8
53 PARAMETER (NAMESR = 'MZIOCH ')
54#endif
55
56C- A B C D E F G H I J K L M
57C- N O P Q R S T U V W X Y Z
58C- 0 1 2 3 4 5 6 7 8 9 + - *
59C- / ( ) $ = b , .
60 DATA ITAB / 47
61 +, -1, 12, -1, 15, -1, 14, -1, 16, 13, -1, -1, -1, -1
62 +, -1, -1, -1, -1, -1, 18, -1, -1, -1, -1, -1, -1, -1
63 +, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, -1, 11, 10
64 +, 19, -1, -1, -1, -1, -2, -2, -2 /
65
66 DATA INV / 39, 38, 2, 9, 6, 4, 8, 24, 19, 40 /
67C- * - B I F D H X S /
68
69 DATA NBITVA / 32, 16, 10, 8 /
70 DATA NBITVB / 29, 14, 9, 7 /
71 DATA NBITVC / 26, 11, 6, 4, 2, 1, 1 /
72 DATA MXVALA / 0, 65536, 1024, 256 /
73 DATA MXVALB / 0, 16384, 512, 128 /
74 DATA MXVALC / 0, 2048, 64, 16, 4, 2, 2 /
75
76#include "zebra/q_sbit1.inc"
77#include "zebra/q_sbyt.inc"
78
79#include "zebra/qtrace.inc"
80
81 NWIOMX = NWIOMP(1)
82 NCH = LEN (CHFORM)
83 IF (NCH.GE.121) GO TO 90
84 CALL UCTOH1 (CHFORM,IQHOLK,NCH)
85
86 CALL IZBCDT (NCH,ITAB)
87 NCH = IQUEST(1)
88 IF (IQUEST(2).NE.0) GO TO 91
89 IF (IQUEST(1).EQ.0) GO TO 91
90
91C-------- SCAN CHARACTER BY CHARACTER
92
93C- NUMERIC 0 ... 9 10 11 12 13 14 15 16 17 18 19
94C- FOR 0 ... 9 * - B I F D H S /
95
96 JPOSR = -1
97 JPOSIN = -1
98 IVAL = 0
99 JCH = 0
100 JU = 0
101 21 NVAL = 0
102 22 JCH = JCH + 1
103 NUM = MCE(JCH)
104 IF (NUM.GE.10) GO TO 24
105
106C-- NUMERIC
107
108 NVAL = 10*NVAL + NUM
109 IF (JCH.LT.NCH) GO TO 22
110 GO TO 92
111
112C-- COUNT = * OR -
113
114 24 IF (NUM.GE.12) GO TO 26
115 IF (NVAL.NE.0) GO TO 92
116 IF (NUM.EQ.11) THEN
117 NVAL = -1
118 JPOSIN = JU
119 IF (JPOSR.GE.0) GO TO 93
120 ENDIF
121 IF (JCH.EQ.NCH) GO TO 92
122 JCH = JCH + 1
123 NUM = MCE(JCH)
124 IF (NUM.LT.12) GO TO 92
125 IF (NUM.GE.19) GO TO 92
126 GO TO 27
127
128C-- TYPE LETTER
129
130 26 IF (NUM.EQ.19) GO TO 29
131 IF (NUM.EQ.18) GO TO 92
132 IF (NVAL.EQ.0) GO TO 92
133 IF (NUM.EQ.15) THEN
134 IF (NVAL.NE.2*(NVAL/2)) GO TO 92
135 ENDIF
136 IVAL = 7
137 27 MU(JU+1) = NUM - 11
138 MU(JU+2) = NVAL
139 JU = JU + 2
140 IF (JCH.EQ.NCH) GO TO 31
141 IF (JPOSIN.LT.0) GO TO 21
142 GO TO 94
143
144C-- REPEAT MARK
145
146 29 IF (NVAL.NE.0) GO TO 92
147 IF (JPOSR.GE.0) GO TO 95
148 IF (JCH.EQ.NCH) GO TO 92
149 JPOSR = JU
150 GO TO 21
151
152C-------- NO TRAILING REGIONS
153
154 31 NU = JU
155 NSECA = NU/2
156 JU = 2
157 IOWD = 65
158 NWIO = 0
159 JFL12 = 1
160 IF (JPOSR.GE.0) THEN
161 IF (JPOSR+2.NE.NU) GO TO 41
162 IF (MU(NU-1).NE.7) GO TO 41
163C- continue if 'CT ... CT / *S'
164 ELSE
165 IF (MU(NU).EQ.0) JFL12=2
166 ENDIF
167
168C-- FORMATS TO BE HANDLED IN CLASSES 1 AND 2 (OR 0)
169C- JFL12 = 2 : '... *T'
170C- 1 : '... -T'
171C- '... NT' AS '... -T'
172C- '... / *S' AS '... -S'
173C- '/ NT' AS '-T'
174
175 32 NSECA = NSECA - 1
176
177C---- CLASS 0 : '-T' OR '*T'
178
179 IQUEST(12) = MU(NU-1)
180 IF (NSECA.EQ.0) THEN
181 IF (JFL12.EQ.1) GO TO 82
182 IQUEST(12) = MSBIT1 (IQUEST(12),4)
183 GO TO 82
184 ENDIF
185
186C---- CLASS 0 : 'CT -T' OR 'CT *T'
187
188 IF (NSECA.GE.2) GO TO 33
189 IF (MU(2).GE.64) GO TO 34
190 IF (JFL12.EQ.2) IQUEST(12)= MSBIT1(IQUEST(12),4)
191 IQUEST(12) = MSBYT (MU(1),IQUEST(12),5,3)
192 IQUEST(12) = MSBYT (MU(2),IQUEST(12),8,6)
193 GO TO 82
194
195C---- CLASS 1 : 'CT CT CT -T'
196C- CLASS 2 : 'CT CT CT *T'
197
198 33 IF (IVAL+NSECA.EQ.2) GO TO 38
199 34 IQUEST(12) = MSBYT (JFL12,IQUEST(12),14,2)
200 IQUEST(12) = MSBYT (MU(1),IQUEST(12),5,3)
201 IQUEST(13) = MU(2)
202 JBTF = 8
203 IF (NSECA.GE.4) GO TO 36
204 IOWD = 2177
205 NWIO = 1
206 IF (NSECA.EQ.1) GO TO 82
207
208 NGR = NSECA
209 CALL MZIOCF (0,MXVALA)
210 IF (NGR.NE.NGRU) GO TO 36
211 NBT = NBITVA(NGRU)
212 GO TO 71
213
214C---- CLASS 1 : 'CT ... CT -T'
215C- CLASS 2 : 'CT ... CT *T'
216
217 36 IQUEST(12) = MSBIT1 (IQUEST(12),4)
218 NGR = MIN (NSECA,3)
219 CALL MZIOCF (0,MXVALB)
220 NBT = NBITVB(NGRU)
221 GO TO 70
222
223C---- CLASS 1 : '*T *T -T'
224C- CLASS 2 : '*T *T *T'
225
226 38 IQUEST(12) = 16*IQUEST(12)
227 IQUEST(12) = MSBYT (MU(1),IQUEST(12), 8,3)
228 IQUEST(12) = MSBYT (MU(3),IQUEST(12),11,3)
229 IQUEST(12) = MSBYT (JFL12,IQUEST(12),14,2)
230 GO TO 82
231
232C-------- WITH TRAILING REGIONS
233
234 41 NSECL = JPOSR/2
235 IF (NSECA.GE.3) GO TO 44
236
237C---- CLASS 3 : '/ *T'
238
239 IQUEST(12) = MU(NU-1)
240 IQUEST(12) = MSBYT (3,IQUEST(12),14,2)
241 IF (NSECA.EQ.2) GO TO 42
242 IF (MU(2).EQ.0) GO TO 82
243 GO TO 32
244
245C---- CLASS 3 : 'CT / *T' OR '/ CT *T'
246
247 42 IF (MU(4).NE.0) GO TO 44
248 IF (MU(2).GE.64) GO TO 44
249 IQUEST(12) = MSBYT (MU(1),IQUEST(12),5,3)
250 IQUEST(12) = MSBYT (MU(2),IQUEST(12),8,6)
251 IF (NSECL.EQ.1) GO TO 82
252 IQUEST(12) = MSBIT1 (IQUEST(12),4)
253 GO TO 82
254
255C---- CLASS 4 : 'CT / CT CT CT' OR 'CT CT / CT CT'
256
257 44 IF (NSECL.EQ.0) GO TO 51
258 IF (NSECL.GE.3) GO TO 61
259 IF (NSECA.GE.5) GO TO 61
260 IF (IVAL+NSECA.EQ.3) GO TO 48
261
262 NGR = NSECA
263 CALL MZIOCF (0,MXVALA)
264 IF (NGR.NE.NGRU) GO TO 61
265
266 IQUEST(12) = MU(1)
267 IQUEST(13) = MU(2)
268 IF (NSECL.EQ.2) IQUEST(12)=IQUEST(12)+8
269 IQUEST(12) = MSBIT1 (IQUEST(12),16)
270
271 JBTF = 5
272 NBT = NBITVA(NGRU)
273 IOWD = 2177
274 NWIO = 1
275 GO TO 71
276
277C---- CLASS 4 : '*T / *T *T' OR '*T *T / *T'
278
279 48 IQUEST(12) = 8*(2*MU(1)+NSECL-1)
280 IQUEST(12) = MSBYT (MU(3),IQUEST(12), 8,3)
281 IQUEST(12) = MSBYT (MU(5),IQUEST(12),11,3)
282 IQUEST(12) = MSBIT1 (IQUEST(12),16)
283 GO TO 82
284
285C-------- NO LEADING REGIONS
286
287C---- CLASS 5 : '/ CT CT CT CT'
288
289 51 IF (IVAL+NSECA.EQ.3) GO TO 58
290 IQUEST(12) = MU(1)
291 IQUEST(13) = MU(2)
292 IQUEST(12) = MSBYT (5,IQUEST(12),14,3)
293 JBTF = 5
294 IF (NSECA.GE.5) GO TO 55
295
296 NGR = NSECA
297 CALL MZIOCF (0,MXVALA)
298 IF (NGR.NE.NGRU) GO TO 55
299 NBT = NBITVA(NGRU)
300 IOWD = 2177
301 NWIO = 1
302 GO TO 71
303
304C---- CLASS 5 : '/ CT ... CT'
305
306 55 IQUEST(12) = MSBIT1 (IQUEST(12),4)
307 NGR = MIN (NSECA,4)
308 CALL MZIOCF (0,MXVALB)
309 NBT = NBITVB(NGRU)
310 GO TO 70
311
312C---- CLASS 5 : '/ *T *T *T'
313
314 58 IQUEST(12) = 16*MU(1)
315 IQUEST(12) = MSBYT (MU(3),IQUEST(12), 8,3)
316 IQUEST(12) = MSBYT (MU(5),IQUEST(12),11,3)
317 IQUEST(12) = MSBYT (5,IQUEST(12),14,3)
318 GO TO 82
319
320C-------- CLASS 6 : 'CT ... CT / CT ... CT'
321
322 61 IQUEST(12) = NSECL
323 IQUEST(13) = MU(2)
324 IF (NSECL.GE.16) GO TO 96
325 IQUEST(12) = MSBYT (MU(1),IQUEST(12),5,3)
326 IQUEST(12) = MSBYT (6,IQUEST(12),14,3)
327
328 JBTF = 8
329 NGR = 3
330 CALL MZIOCF (0,MXVALB)
331 NBT = NBITVB(NGRU)
332
333C------ LONG PACKING
334
335C-- PACK FIRST I/O WORD
336
337 70 IF (NGRU.EQ.1) GO TO 73
338
339 71 JBTC = 1
340 DO 72 JL=2,NGRU
341 IQUEST(12) = MSBYT (MU(JU+1),IQUEST(12),JBTF,3)
342 JBTF = JBTF + 3
343 JBTC = JBTC + NBT
344 IQUEST(13) = MSBYT (MU(JU+2),IQUEST(13),JBTC,NBT)
345 72 JU = JU + 2
346
347 IF (NGRU.EQ.NSECA) GO TO 82
348 73 NSECD = NGRU
349 JWIO = 13
350
351C---- PACK NEXT I/O WORD
352
353 74 JWIO = JWIO + 1
354 IQUEST(JWIO) = MU(JU+1)
355 JBT = 4
356 NGRU = 1
357 NGR = MIN (7,NSECA-NSECD)
358 IF (NGR.EQ.1) GO TO 77
359
360 CALL MZIOCF (JU,MXVALC)
361 IF (NGRU.EQ.1) GO TO 77
362 JUST = JU
363 DO 76 JL=2,NGRU
364 JU = JU + 2
365 IQUEST(JWIO) = MSBYT (MU(JU+1),IQUEST(JWIO),JBT,3)
366 76 JBT = JBT + 3
367 JU = JUST
368
369 77 IQUEST(JWIO-1) = MSBYT (NGRU,IQUEST(JWIO-1),30,3)
370 NBT = NBITVC(NGRU)
371
372 DO 79 JL=1,NGRU
373 IQUEST(JWIO) = MSBYT (MU(JU+2),IQUEST(JWIO),JBT,NBT)
374 JBT = JBT + NBT
375 79 JU = JU + 2
376
377 NSECD = NSECD + NGRU
378 IF (NSECD.LT.NSECA) GO TO 74
379 NWIO = JWIO - 12
380
381 IF (NWIO.GE.NWIOMX) GO TO 97
382 IF (NWIO.GE.16) GO TO 97
383 IOWD = 64*(32*NWIO+NWIO+1) + 1
384
385 82 IOWD = MSBYT (IQUEST(12),IOWD,17,16)
386 IQUEST(12) = IOWD
387 IQUEST(1) = NWIO
388
389 CALL UCOPY (IQUEST(12),IODVEC,NWIO+1)
390 IQCETK(121) = IQBLAN
391#if defined(CERNLIB_QDEBPRI)
392 IF (NQLOGM.GE.1) WRITE (IQLOG,9088) NWIO,CHFORM
393 9088 FORMAT (' MZIOCH-',I5,' extra I/O words for Format ',A)
394#endif
395#include "zebra/qtrace99.inc"
396 RETURN
397
398C------ ERROR CONDITIONS
399
400C-- CHARACTER STRING TOO LONG
401 90 NQFATA = 2
402 IQUEST(12) = NCH
403 GO TO 99
404
405C-- STRING INVALID
406 91 NQCASE = 1
407 NQFATA = 3
408 IQUEST(12) = IQUEST(1)
409 IQUEST(13) = IQUEST(2)
410 IF (IQUEST(1).EQ.0) GO TO 99
411 GO TO 98
412
413C-- I/O DESCRIPTOR TOO LONG
414 97 NQCASE = 7
415 IQUEST(12) = NWIOMX
416 IQUEST(13) = NWIO + 1
417 GO TO 98
418
419C-- TOO MANY SECTORS
420 96 NQCASE = 6
421 IQUEST(12) = NSECA
422 IQUEST(13) = NSECL
423 GO TO 98
424
425C-- / OCCURS TWICE
426 95 NQCASE = 1
427
428C-- -T NOT LAST SECTOR IN THE STRING
429 94 NQCASE = NQCASE + 1
430
431C-- -T NOT ALLOWED IN REPEAT
432 93 NQCASE = NQCASE + 1
433
434C-- BAD SYNTAX
435 92 NQCASE = NQCASE + 2
436 IQUEST(12) = JCH
437 IQUEST(13) = 0
438
439 98 DO 88 JCH=1,NCH
440 JCET = MCE(JCH)
441 IF (JCET.LT.10) THEN
442 MCE(JCH)=IQNUM(JCET+1)
443 ELSE
444 JCET = INV(JCET-9)
445 MCE(JCH) = IQLETT(JCET)
446 ENDIF
447 88 CONTINUE
448 CALL UTRANS (MCE,IQUEST(14),NCH,1,4)
449 NQFATA = (NCH-1)/4 + 4
450
451 99 IQUEST(11) = IQCETK(121)
452#include "zebra/qtofatal.inc"
453 END
454* ==================================================
455#include "zebra/qcardl.inc"