]> git.uio.no Git - u/mrichter/AliRoot.git/blame - MINICERN/packlib/zebra/fq/fziffx.F
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Changes needed by ICC/IFC compiler (Intel)
[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / fq / fziffx.F
CommitLineData
fe4da5cc 1*
2* $Id$
3*
4* $Log$
5* Revision 1.2 1996/04/18 16:10:33 mclareni
6* Incorporate changes from J.Zoll for version 3.77
7*
8* Revision 1.1.1.1 1996/03/06 10:47:13 mclareni
9* Zebra
10*
11*
12#include "zebra/pilot.h"
13 SUBROUTINE FZIFFX (JSTAGE)
14
15C- Service routine to FZIN for exchange mode
16
17#include "zebra/zbcd.inc"
18#include "zebra/zmach.inc"
19#include "zebra/zunit.inc"
20#include "zebra/mqsys.inc"
21#include "zebra/eqlqf.inc"
22#include "zebra/mzcn.inc"
23#include "zebra/mzct.inc"
24#include "zebra/mzioc.inc"
25#include "zebra/mzcwk.inc"
26#include "zebra/fzci.inc"
27#include "zebra/fzcseg.inc"
28#include "zebra/fzcocc.inc"
29C-------------- End CDE --------------
30 DIMENSION MPILOT(10)
31 REAL CHDATA
32#if defined(CERNLIB_QMVDS)
33 SAVE CHDATA
34#endif
35 EQUIVALENCE (MPILOT(1),IPILI(1))
36 EQUIVALENCE (LRTYP,IDI(2)), (ICHDAT,CHDATA)
37#if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
38 DIMENSION NAMESR(2)
39 DATA NAMESR / 4HFZIF, 4HFX /
40#endif
41#if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
42 DATA NAMESR / 6HFZIFFX /
43#endif
44#if !defined(CERNLIB_QTRHOLL)
45 CHARACTER NAMESR*8
46 PARAMETER (NAMESR = 'FZIFFX ')
47#endif
48 DATA CHDATA / 12345.0 /
49
50#include "zebra/q_jbyt.inc"
51
52#include "zebra/qtrace.inc"
53
54 GO TO (101,201,301), JSTAGE
55
56C-----------------------------------------------------
57C- OBTAIN AND DIGEST NEXT PILOT RECORD
58C-----------------------------------------------------
59
60 100 CONTINUE
61 101 ISTENI = 1
62 LBPARI = LQFI + INCBPI
63#if defined(CERNLIB_FZCHANNEL)
64 IF (IACMOI.EQ.3) THEN
65 IF (IADOPI.EQ.0) GO TO 740
66 ENDIF
67#endif
68#if defined(CERNLIB_FZMEMORY)
69 IF (IFIFOI.EQ.3) THEN
70 IADOPI = IQ(KQSP+LQFI+8)
71 IQ(KQSP+LQFI+1) = IADOPI
72 IF (IADOPI.EQ.0) GO TO 740
73 CALL VZERO (IQ(KQSP+LBPARI-9),9)
74#endif
75#if (defined(CERNLIB_QDEVZE))&&(defined(CERNLIB_FZMEMORY))
76 IF (LOGLVI.GE.3) WRITE (IQLOG,9142) IADOPI
77 9142 FORMAT (' DEVZE FZIN, relative buffer adr =',I9)
78#endif
79#if defined(CERNLIB_FZMEMORY)
80 ENDIF
81#endif
82#if defined(CERNLIB_QDEBPRI)
83 IF (LOGLVI.GE.3) WRITE (IQLOG,9101) IOPTIR,IOPTIE
84 9101 FORMAT (' FZIFFX- Hunt for pilot, options RUN/EVENT =',2I2)
85#endif
86
87 IFLAGI = 1
88 CALL FZIREC
89 IF (IFLAGI.NE.0) GO TO 999
90#if defined(CERNLIB_QDEBPRI)
91 IF (LOGLVI.GE.3) WRITE (IQLOG,9102) NRECAI,IDI
92 9102 FORMAT (' FZIFFX- Seen LR #',I7,' with NWRL/LRTYP=',I7,I3)
93#endif
94 ISTENI = 0
95 IF (LRTYP.GE.4) GO TO 100
96 IF (LRTYP.EQ.1) GO TO 422
97
98#if defined(CERNLIB_FQXISN)
99 CALL FZITRN (IPILI,10)
100#endif
101#if !defined(CERNLIB_FQXISN)
102 IF (IDAFOI.EQ.0) THEN
103 CALL FZITRN (IPILI,10)
104 ELSE
105 MFO(1) = 3
106 MFO(2) = 1
107 MFO(3) = 1
108 MFO(4) = -1
109 JFOEND = 4
110 CALL FZITRX (IPILI,10)
111 ENDIF
112#endif
113 IF (IFLAGI.NE.0) GO TO 999
114
115 IACTVI = 2
116 IEVFLI = 3 - LRTYP
117 IQ(KQSP+LQFI+15) = IQ(KQSP+LQFI+15) + 1
118
119C-- check values in pilot head
120
121 IF (IPILI(1).NE.ICHDAT) GO TO 741
122 IF (NWTXI .LT.0) GO TO 743
123 IF (NWSEGI.GE.61) GO TO 743
124 IF (NWSEGI.LT.0) GO TO 743
125 IF (NWTABI.LT.0) GO TO 744
126 IF (NWBKI .LT.0) GO TO 744
127 IF (NWUHCI.LT.0) GO TO 745
128
129C-- skip to start/end of run
130 IF (IOPTIR.NE.0) THEN
131 IQ(KQSP+LQFI+26) = 0
132 GO TO 100
133 ENDIF
134
135 IF (IEVFLI.LT.IOPTIE) GO TO 100
136
137#if defined(CERNLIB_QDEBPRI)
138 IF (LOGLVI.GE.3) WRITE (IQLOG,9107,ERR=107) MPILOT,MPILOT
139 107 CONTINUE
140 9107 FORMAT (10X,'The 10 pilot control words : ',
141#endif
142#if (defined(CERNLIB_QDEBPRI))&&(!defined(CERNLIB_HEX))
143 F/1X,4O23/1X,4O23/1X,2O23
144 F/1H0,9X,F13.1,3(9X,I14)/1X,4(9X,I14)/1X,2(9X,I14))
145#endif
146#if (defined(CERNLIB_QDEBPRI))&&(defined(CERNLIB_HEX))
147 F/10X,4Z17/10X,4Z17/10X,2Z17
148 F/1H0,9X,F17.1,3I17/10X,4I17/10X,2I17)
149#endif
150
151C-- Read I/O char. for User Header Vector
152
153 NWIOI = 0
154 NWUHI = 0
155 LFIIOC = LQFI + JAUIOC
156 IQ(KQSP+LFIIOC) = 0
157 IF (NWUHCI.EQ.0) GO TO 121
158
159#if defined(CERNLIB_FQXISN)
160 CALL FZITRN (IOCHI,1)
161#endif
162#if !defined(CERNLIB_FQXISN)
163 IF (IDAFOI.EQ.0) THEN
164 CALL FZITRN (IOCHI,1)
165 ELSE
166 MFO(1) = 1
167 MFO(2) = -1
168 JFOEND = 2
169 CALL FZITRX (IOCHI,1)
170 ENDIF
171#endif
172 IF (IFLAGI.NE.0) GO TO 999
173
174 NWIOI = JBYT (IOCHI(1),7,5)
175 IF (NWIOI.EQ.0) THEN
176 NWIOI = 1
177 IF (IOCHI(1).GE.8) GO TO 742
178 IF (IOCHI(1).LT.0) GO TO 742
179 IF (IOCHI(1).EQ.0) IOCHI(1)=1
180 ELSE
181 J = JBYT (IOCHI(1),12,5)
182 IF (J+1.NE.NWIOI) GO TO 742
183 ENDIF
184 IF (NWIOI.LT.2) GO TO 116
185
186#if defined(CERNLIB_FQXISN)
187 CALL FZITRN (IQ(KQSP+LFIIOC+2),NWIOI-1)
188#endif
189#if !defined(CERNLIB_FQXISN)
190 IF (IDAFOI.EQ.0) THEN
191 CALL FZITRN (IQ(KQSP+LFIIOC+2),NWIOI-1)
192 ELSE
193 MFO(1) = 1
194 MFO(2) = -1
195 JFOEND = 2
196 CALL FZITRX (IOCHI(2),NWIOI-1)
197 CALL UCOPY (IOCHI(2),IQ(KQSP+LFIIOC+2),NWIOI-1)
198 ENDIF
199#endif
200 IF (IFLAGI.NE.0) GO TO 999
201
202 116 IQ(KQSP+LFIIOC) = NWIOI
203 IQ(KQSP+LFIIOC+1) = IOCHI(1)
204
205C-- Read User Header Vector
206
207 LUHEAI = LQWKFZ
208 NWUHA = NWUHCI - NWIOI
209 NWUHI = MIN (NWUHA,NWUMXI)
210#if defined(CERNLIB_FQXISN)
211 CALL FZITRN (LQ(LUHEAI),NWUHI)
212#endif
213#if !defined(CERNLIB_FQXISN)
214 IF (IDAFOI.EQ.0) THEN
215 CALL FZITRN (LQ(LUHEAI),NWUHI)
216 ELSE
217 CALL MZIOCR (IOCHI)
218 CALL FZITRX (LQ(LUHEAI),NWUHI)
219 ENDIF
220#endif
221 IF (IFLAGI.NE.0) GO TO 999
222 N4SKII = NWUHA - NWUHI
223
224#if defined(CERNLIB_QDEBPRI)
225 IF (LOGLVI.GE.3) THEN
226 N = MIN (8,NWUHI)
227 IF (LOGLVI.GE.4) THEN
228 WRITE (IQLOG,9113) NWIOI
229 WRITE (IQLOG,9115) (IOCHI(J),J=1,NWIOI)
230 N = NWUHI
231 ENDIF
232 WRITE (IQLOG,9114) NWUHI,N
233 WRITE (IQLOG,9115) (LQ(LUHEAI+J),J=0,N-1)
234 ENDIF
235 9113 FORMAT (10X,I2,' words I/O characteristic for UHV =')
236 9114 FORMAT (10X,I4,' words of User Header accepted, dump the first'
237 F,I5)
238#endif
239#if (defined(CERNLIB_QDEBPRI))&&(!defined(CERNLIB_HEX))
240 9115 FORMAT (1X,4O23)
241#endif
242#if (defined(CERNLIB_QDEBPRI))&&(defined(CERNLIB_HEX))
243 9115 FORMAT (10X,4Z17)
244#endif
245
246
247C---- Read the Segment Table
248
249 121 LFISEG = LQFI + JAUSEG
250 IF (NWSEGI.EQ.0) GO TO 124
251
252#if defined(CERNLIB_FQXISN)
253 CALL FZITRN (IQ(KQSP+LFISEG+1),NWSEGI)
254#endif
255#if !defined(CERNLIB_FQXISN)
256 IF (IDAFOI.EQ.0) THEN
257 CALL FZITRN (IQ(KQSP+LFISEG+1),NWSEGI)
258 ELSE
259 NSEG = NWSEGI / 3
260 MFO(1) = 5
261 MFO(2) = -1
262 JFOEND = 2
263 CALL FZITRX (IQ(KQSP+LFISEG+1),2*NSEG)
264 IF (IFLAGI.NE.0) GO TO 999
265 MFO(1) = 1
266 MFO(2) = -1
267 CALL FZITRX (IQ(KQSP+LFISEG+1+2*NSEG),NSEG)
268 ENDIF
269#endif
270 IF (IFLAGI.NE.0) GO TO 999
271
272 124 IQ(KQSP+LFISEG) = NWSEGI
273
274C---- Read the Text Vector
275
276 LTEXT = LQ(KQSP+LQFI-2)
277 IF (LTEXT.NE.0) IQ(KQSP+LTEXT+1)=0
278 IF (NWTXI.EQ.0) GO TO 141
279
280 IF (LTEXT.EQ.0) THEN
281 N4SKII = N4SKII + NWTXI
282 GO TO 141
283 ENDIF
284
285C-- increase the size of the text buffer if necessary
286
287 NINC = NWTXI + 4 - IQ(KQSP+LTEXT-1)
288 IF (NINC.GT.0) THEN
289 CALL FZIREC
290 CALL MZPUSH (JQPDVS,LTEXT,0,NINC,'.')
291 L4STAI = 0
292 CALL FZIREC
293 ENDIF
294
295C-- transmit to text buffer
296
297#if defined(CERNLIB_FQXISN)
298 CALL FZITRN (IQ(KQSP+LTEXT+5),NWTXI)
299#endif
300#if !defined(CERNLIB_FQXISN)
301 IF (IDAFOI.EQ.0) THEN
302 CALL FZITRN (IQ(KQSP+LTEXT+5),NWTXI)
303 ELSE
304 MFO(1) = 5
305 MFO(2) = 0
306 JFOEND = 2
307 JFOREP = 0
308 CALL FZITRX (IQ(KQSP+LTEXT+5),NWTXI)
309 ENDIF
310#endif
311 IF (IFLAGI.NE.0) GO TO 999
312 IQ(KQSP+LTEXT+1) = NWTXI
313
314C---- No early table words
315
316 141 LFIEAR = LQFI + JAUEAR
317 IQ(KQSP+LFIEAR) = 0
318
319 CALL FZIREC
320 GO TO 999
321
322C-------------------------------------------------
323C- READ TABLE
324C-------------------------------------------------
325
326 201 L4STAI = 0
327 IFLAGI = 0
328 CALL FZIREC
329 LIN = LQTA + NWTABI
330#if defined(CERNLIB_FQXISN)
331 CALL FZITRN (LQ(LIN),NWTABI)
332#endif
333#if !defined(CERNLIB_FQXISN)
334 IF (IDAFOI.EQ.0) THEN
335 CALL FZITRN (LQ(LIN),NWTABI)
336 ELSE
337 MFO(1) = 1
338 MFO(2) = -1
339 JFOEND = 2
340 CALL FZITRX (LQ(LIN),NWTABI)
341 ENDIF
342#endif
343 IF (IFLAGI.NE.0) GO TO 999
344 CALL FZIREC
345 GO TO 999
346
347C-------------------------------------------------
348C- READ THE DATA
349C-------------------------------------------------
350
351 301 L4STAI = 0
352 IFLAGI = 0
353 CALL FZIREC
354 LMT = LQMTA
355 302 IF (LQ(LMT+1).NE.0) GO TO 311
356
357C---- Skip segment to be ignored
358
359 N4SKII = N4SKII - LQ(LMT+3)
360 GO TO 348
361
362C-------- Read segment to accept
363
364 311 LSTA = LQ(LMT+3)
365 LEND = LQ(LMT+4)
366#if !defined(CERNLIB_FQXISN)
367 IF (IDAFOI.EQ.0) GO TO 341
368
369C------ Read segment in exchange mode, bank-by-bank
370
371 LIN = LSTA
372
373C- Next bank : first word
374 322 MFO(1) = 1
375 MFO(2) = -1
376 JFOEND = 2
377 CALL FZITRX (LQ(KQS+LIN),1)
378 IF (IFLAGI.NE.0) GO TO 999
379 IWD = LQ(KQS+LIN)
380 NST = JBYT (IWD,1,16) - 12
381#endif
382#if (!defined(CERNLIB_FQXISN))&&(defined(CERNLIB_QDEBPRI))
383 IF (LOGLVI.GE.4) WRITE (IQLOG,9322) LIN,L4CURI-L4STAI-1,NST
384 9322 FORMAT (' FZIFFX- Next bank : Lst, NWdone, NIO+NL =',I9,2I6)
385#endif
386#if !defined(CERNLIB_FQXISN)
387 IF (NST.LT.0) GO TO 326
388
389C-- True bank
390
391 IQLN = LIN
392 IQLS = LIN + NST + 1
393 IF (IQLS+8.GE.LEND) GO TO 752
394
395C- I/O words, links, next-link, up-link
396 MFO(1) = 1
397 MFO(2) = NST + 2
398
399C- origin, numeric ID
400 MFO(3) = 2
401 MFO(4) = 2
402
403C- Hollerith ID
404 MFO(5) = 5
405 MFO(6) = 1
406
407C- NL, NS, ND, status
408 MFO(7) = 1
409 MFO(8) = -1
410 JFOEND = 8
411 CALL FZITRX (LQ(KQS+LIN+1), NST+9)
412 IF (IFLAGI.NE.0) GO TO 999
413 IQNIO = JBYT (IQ(KQS+IQLS),19,4)
414 IQNL = IQ(KQS+IQLS-3)
415 IQND = IQ(KQS+IQLS-1)
416#endif
417#if (!defined(CERNLIB_FQXISN))&&(defined(CERNLIB_QDEBPRI))
418 IF (LOGLVI.GE.4) THEN
419 IQID = IQ(KQS+IQLS-4)
420 WRITE (IQLOG,9323) IQID,IQNL,IQND,IQNIO
421 ENDIF
422 9323 FORMAT (' FZIFFX- ID,NL,ND,NIO = ',A4,2I8,I4)
423#endif
424#if !defined(CERNLIB_FQXISN)
425 IF (IQNIO+IQNL.NE.NST) GO TO 751
426 IF (IQND.LT.0) GO TO 751
427
428C- data words
429 LIN = IQLS + IQND + 9
430 IF (IQND.EQ.0) GO TO 324
431 IF (LIN.GT.LEND) GO TO 753
432
433 CALL MZIOCR (LQ(KQS+IQLN))
434 CALL FZITRX (IQ(KQS+IQLS+1), IQND)
435 IF (IFLAGI.NE.0) GO TO 999
436 324 IF (LIN.LT.LEND) GO TO 322
437 GO TO 348
438
439C-- Short dead region
440
441 326 NWD = JBYT (IWD,17,IQDROP-17)
442 IF (NWD.EQ.0) GO TO 751
443 IF (NWD.NE.NST+12) GO TO 751
444 IF (JBYT(IWD,IQDROP,IQBITW-IQDROP).NE.1) GO TO 751
445 IF (NWD.GT.1) THEN
446 IF (LIN+NWD.GT.LEND) GO TO 754
447 MFO(1) = 0
448 MFO(2) = -1
449 JFOEND = 2
450 CALL FZITRX (LQ(KQS+LIN+1), NWD-1)
451 IF (IFLAGI.NE.0) GO TO 999
452 ENDIF
453 LIN = LIN + NWD
454 IF (LIN.LT.LEND) GO TO 322
455 GO TO 348
456#endif
457
458C------ Read segment in native mode
459
460 341 CALL FZITRN (LQ(KQS+LSTA),LEND-LSTA)
461 IF (IFLAGI.NE.0) GO TO 999
462
463C-- Verify bank chaining
464
465 LIN = LSTA
466 344 IWD = LQ(KQS+LIN)
467 NST = JBYT (IWD,1,16) - 12
468 IF (NST.LT.0) GO TO 346
469
470C-- True bank
471
472 IQLN = LIN
473 IQLS = LIN + NST + 1
474 IF (IQLS+8.GE.LEND) GO TO 752
475
476 IQNIO = JBYT (IQ(KQS+IQLS),19,4)
477 IQNL = IQ(KQS+IQLS-3)
478 IQND = IQ(KQS+IQLS-1)
479 IF (IQNIO+IQNL.NE.NST) GO TO 751
480 IF (IQND.LT.0) GO TO 751
481
482 LIN = IQLS + IQND + 9
483 IF (LEND-LIN) 753, 348, 344
484
485C-- Short dead region
486
487 346 NWD = JBYT (IWD,17,IQDROP-17)
488 IF (NWD.EQ.0) GO TO 751
489 IF (NWD.NE.NST+12) GO TO 751
490 IF (JBYT(IWD,IQDROP,IQBITW-IQDROP).NE.1) GO TO 751
491 LIN = LIN + NWD
492 IF (LEND-LIN) 754, 348, 344
493
494C---- End of segment
495
496 348 LMT = LMT + 8
497 IF (LMT.LT.LQMTE) GO TO 302
498
499 IF (N4SKII.NE.0) THEN
500#if defined(CERNLIB_FQXISN)
501 CALL FZITRN (IPILI,0)
502#endif
503#if !defined(CERNLIB_FQXISN)
504 IF (IDAFOI.EQ.0) THEN
505 CALL FZITRN (IPILI,0)
506 ELSE
507 CALL FZITRX (IPILI,0)
508 ENDIF
509#endif
510 IF (IFLAGI.NE.0) GO TO 999
511 ENDIF
512 CALL FZIREC
513 IF (N4RESI.NE.0) GO TO 755
514 GO TO 999
515
516C-------------------------------------------------
517C- START / END-OF-RUN
518C-------------------------------------------------
519
520 422 LUHEAI = LQWKFZ
521 NWUHI = MIN (IDI(1), NQWKTT)
522#if defined(CERNLIB_FQXISN)
523 CALL FZITRN (LQ(LUHEAI),NWUHI)
524#endif
525#if !defined(CERNLIB_FQXISN)
526 IF (IDAFOI.EQ.0) THEN
527 CALL FZITRN (LQ(LUHEAI),NWUHI)
528 ELSE
529 MFO(1) = 2
530 MFO(2) = -1
531 JFOEND = 2
532 CALL FZITRX (LQ(LUHEAI),NWUHI)
533 ENDIF
534#endif
535 IF (IFLAGI.NE.0) GO TO 999
536
537 CALL FZIREC
538 JRETCD = -2
539 IQ(KQSP+LBPARI-7) = 0
540 GO TO 999
541
542C-------------------------------------------------
543C- ERROR CONDITIONS
544C-------------------------------------------------
545
546#if defined(CERNLIB_FZMEMORY)||defined(CERNLIB_FZCHANNEL)
547C- JERROR = 240 user routine or buffer not connected for C/M mode
548 740 JERROR = 240
549 JRETCD = 4
550 GO TO 999
551#endif
552
553C-- Bad construction
554
555C- JERROR = 241 check-word which should be 12345.0 is wrong
556 741 JERROR = 241
557 IQUEST(14)= 0
558 IQUEST(15)= 0
559 IQUEST(16)= IPILI(1)
560 IQUEST(17)= ICHDAT
561 NWERR = 4
562 GO TO 749
563
564C- JERROR = 242 control wd of I/O char. for user header invalid
565 742 JERROR = 242
566 IQUEST(14)= NWUHCI
567 IQUEST(15)= 0
568 IQUEST(16)= IOCHI(1)
569 NWERR = 3
570 GO TO 749
571
572C- JERROR = 243 NWSEGI or NWTXI wrong
573 743 JERROR = 243
574 IQUEST(14)= NWSEGI
575 IQUEST(15)= NWTXI
576 NWERR = 2
577 GO TO 749
578
579C- JERROR = 244 NWTABI or NWBKI wrong
580 744 JERROR = 244
581 IQUEST(14)= NWTABI
582 IQUEST(15)= NWBKI
583 NWERR = 2
584 GO TO 749
585
586C- JERROR = 245 NWUHCI wrong
587 745 JERROR = 245
588 IQUEST(14)= NWUHCI
589 NWERR = 2
590
591 749 JRETCD = 6
592 GO TO 780
593
594C-- Bad data
595
596C- JERROR = 251 inconsistent bank parameters
597 751 JERROR = 251
598 GO TO 759
599
600C- JERROR = 252 link part of bank overshoots segment end
601 752 JERROR = 252
602 GO TO 759
603
604C- JERROR = 253 data part of bank overshoots segment end
605 753 JERROR = 253
606 GO TO 759
607
608C- JERROR = 254 short dead region overshoots segment end
609 754 JERROR = 254
610 GO TO 759
611
612C- JERROR = 255 bank material does not end exactly with LR
613 755 JERROR = 255
614
615 759 JRETCD = 5
616
617 780 IQ(KQSP+LBPARI-9) = -3
618 IQ(KQSP+LBPARI-1) = 0
619#include "zebra/qtrace99.inc"
620 RETURN
621 END
622* ==================================================
623#include "zebra/qcardl.inc"