]> git.uio.no Git - u/mrichter/AliRoot.git/blame - MINICERN/packlib/zebra/fq/fzcopy.F
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Mostly minor style modifications to be ready for cloning with EMCAL
[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / fq / fzcopy.F
CommitLineData
fe4da5cc 1*
2* $Id$
3*
4* $Log$
5* Revision 1.2 1996/04/18 16:10:18 mclareni
6* Incorporate changes from J.Zoll for version 3.77
7*
8* Revision 1.1.1.1 1996/03/06 10:47:10 mclareni
9* Zebra
10*
11*
12#include "zebra/pilot.h"
13 SUBROUTINE FZCOPY (LUNIN,LUNOUT,IEVP,CHOPT,NIOP,NUHP,IUHEAD)
14
15C- Control routine to copy d/s without expansion, user called
16
17#include "zebra/zstate.inc"
18#include "zebra/zunit.inc"
19#include "zebra/mqsys.inc"
20#include "zebra/eqlqf.inc"
21#include "zebra/mzcwk.inc"
22#include "zebra/mzct.inc"
23#include "zebra/fzci.inc"
24#include "zebra/fzcx.inc"
25#include "zebra/fzcseg.inc"
26C-------------- End CDE --------------
27 DIMENSION LUNIN(9),LUNOUT(9),IEVP(9)
28 DIMENSION NIOP(9),NUHP(9),IUHEAD(99)
29 DIMENSION NEWOPT(3)
30 CHARACTER CHOPT*(*)
31 EQUIVALENCE (LRTYP,IDI(2))
32#if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
33 DIMENSION NAMESR(2)
34 DATA NAMESR / 4HFZCO, 4HPY /
35#endif
36#if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
37 DATA NAMESR / 6HFZCOPY /
38#endif
39#if !defined(CERNLIB_QTRHOLL)
40 CHARACTER NAMESR*8
41 PARAMETER (NAMESR = 'FZCOPY ')
42#endif
43
44#include "zebra/q_jbyt.inc"
45
46#include "zebra/qtrace.inc"
47
48 LUNNI = LUNIN(1)
49 LUNNX = LUNOUT(1)
50 IEVFLX = IEVP(1)
51 IOCHX(1)= NIOP(1)
52 NWUHOR = MAX (NUHP(1),0)
53 NWUHX = MIN (NWUHOR,400)
54 NWFILX = 0
55 NWMEMT = 0
56 IFSENT = 0
57 ICOPYX = 7
58 CALL UOPTC (CHOPT,'ITP',NEWOPT)
59
60C---- Set current output unit
61
62 IF (LUNNX.NE.LUNX) CALL FZLOC (LUNNX,2)
63#if defined(CERNLIB_QDEBPRI)
64 IF (LOGLVX.GE.2) THEN
65 IF (LOGLVX.GE.3) WRITE (IQLOG,9110)
66 WRITE (IQLOG,9111) LUNNI,LUNNX,IEVFLX,IACTVX,CHOPT
67 ENDIF
68 9110 FORMAT (1X)
69 9111 FORMAT (' FZCOPY- LUNin/out=',2I3,' IEVFL,IACTV,OPT=',2I3,1X,A)
70
71#endif
72#if defined(CERNLIB_QPRINT)
73 IF (NWUHOR.GT.NWUHX) THEN
74 IF (LOGLVX.GE.-2) WRITE (IQLOG,9112) LUNX,NWUHOR
75 ENDIF
76 9112 FORMAT (1X/' FZOUT. LUN=',I4,' Of ',I4,' user header words',
77 F' only 400 are taken !!!')
78#endif
79#if defined(CERNLIB_FZCHANNEL)
80 IF (IACMOX.EQ.3) THEN
81 IF (IADOPX.EQ.0) GO TO 907
82 ENDIF
83
84#endif
85#if defined(CERNLIB_FZMEMORY)
86 IF (IFIFOX.EQ.3) THEN
87 IADOPX = IQ(KQSP+LQFX+8)
88 IF (IADOPX.EQ.0) GO TO 907
89 IQ(KQSP+LQFX+1) = IADOPX
90 ENDIF
91
92#endif
93 IF (IACTVX.GE.16) GO TO 901
94
95C---- Set current input unit
96
97 IF (LUNNI.NE.LUNI) CALL FZLOC (LUNNI,1)
98
99C-- Check compatibility
100
101 IF (IDAFOX.NE.IDAFOI) GO TO 941
102 IF (IFIFOX.EQ.4) GO TO 944
103 IF (IFIFOI.EQ.4) GO TO 944
104 IF (IFIFOI.EQ.0) THEN
105 IF (MAXREI.GE.NQWKTB) GO TO 942
106 ENDIF
107
108C-- Get the parameters of the pending d/s
109
110 LFIIOC = LQFI + JAUIOC
111 LFISEG = LQFI + JAUSEG
112
113 NWRDAI = IQ(KQSP+LQFI+20)
114 NRECAI = IQ(KQSP+LQFI+21)
115 LRTYP = IQ(KQSP+LQFI+27)
116 NWTABI = IQ(KQSP+LQFI+41)
117 NWBKI = IQ(KQSP+LQFI+42)
118 NWSEGI = IQ(KQSP+LFISEG)
119 LENTRI = IQ(KQSP+LQFI+43)
120 IF (LRTYP.GE.5) GO TO 949
121 IF (LRTYP.LE.1) GO TO 949
122
123 JRETCD = 0
124 JERROR = 0
125 NWERR = 0
126#if defined(CERNLIB_FZCHANNEL)
127 IF (IACMOI.EQ.3) THEN
128 IF (IACMOX.EQ.3) GO TO 943
129 ENDIF
130#endif
131
132C------ Transmit the pilot
133
134 NWSEGX = NWSEGI
135 NWTABX = NWTABI
136 NWBKX = NWBKI
137 LENTRX = LENTRI
138
139 NWTXX = 0
140 NWUHCX = 0
141 NWIOX = 0
142
143C-- Ready I/O characteristic
144
145 IF (NWUHX.EQ.0) GO TO 39
146 IF (NEWOPT(1).EQ.0) THEN
147 NWIOX = IQ(KQSP+LFIIOC)
148 CALL UCOPY (IQ(KQSP+LFIIOC+1),IOCHX,NWIOX)
149 GO TO 38
150 ENDIF
151
152 IF (IOCHX(1)) 34, 32, 33
153 32 IOCHX(1) = 3
154 33 NWIOX = 1
155 IF (IOCHX(1).LT.8) GO TO 38
156 34 NWIOX = JBYT (IOCHX(1), 7,5)
157 J = JBYT (IOCHX(1),12,5)
158 IF (JBYT (IOCHX(1), 1,6).NE.1) GO TO 903
159 IF (NWIOX.GT.16) GO TO 903
160 IF (NWIOX.NE.J+1) GO TO 903
161
162 IF (NWIOX.GT.1) CALL UCOPY (NIOP,IOCHX,NWIOX)
163 38 NWUHCX = NWUHX + NWIOX
164 39 CONTINUE
165
166C-- Ready text vector
167
168 IF (NEWOPT(2).EQ.0) THEN
169 LTEXTX = LQ(KQSP+LQFI-2)
170 ELSE
171 LTEXTX = LQ(KQSP+LQFX-2)
172 ENDIF
173 IF (LTEXTX.NE.0) CALL FZOTXT
174
175C-- Ready segment table
176
177 NQSEG = NWSEGX / 3
178 IF (NQSEG.NE.0) THEN
179 N = 2*NQSEG
180 CALL UCOPY (IQ(KQSP+LFISEG+1), IQSEGH,N)
181 CALL UCOPY (IQ(KQSP+LFISEG+1+N), IQSEGD,NQSEG)
182 ENDIF
183 IQSGLU = LUNI
184
185C-- Ready early table
186
187C- ISTTAB : transmission status of table words
188C- -1 not yet read, 0 read into LQ(LQTA), +1 written
189
190 LQTA = LQWKTB
191 LQTE = LQTA + 2*NWTABI
192
193 ISTTAB = 1
194 IF (NWTABX.EQ.0) GO TO 121
195 ISTTAB = -1
196#if defined(CERNLIB_FZFFNAT)
197 IF (NWTABX.GE.41) GO TO 121
198
199 IF (IFIFOI.EQ.0) THEN
200 LFIEAR = LQFI + JAUEAR
201 NTBE = IQ(KQSP+LFIEAR)
202 IF (NTBE.NE.0) THEN
203 CALL UCOPY (IQ(KQSP+LFIEAR+1),LQ(LQTA),NWTABI)
204 ISTTAB = 0
205 GO TO 121
206 ENDIF
207 ENDIF
208
209 IF (IFIFOX.NE.0) GO TO 121
210 IF (IFIFOI.EQ.0) THEN
211 CALL FZIFFN (2)
212 ELSE
213 CALL FZIFFX (2)
214 ENDIF
215 IF (JRETCD.NE.0) GO TO 971
216 LQTA = LQTA + NWTABI
217 ISTTAB = 0
218#endif
219
220C------ Output the pilot record
221
222 121 IDX(2) = 3
223 IF (IEVFLX.NE.0) IDX(2)=2
224 NWMEMT = 20 + NWUHCX + NWSEGX + NWTXX + NWTABX + NWBKX
225
226#if defined(CERNLIB_QDEBPRI)
227 IF (LOGLVX.GE.2) WRITE (IQLOG,9121) LENTRX,NWTABX,NWBKX
228 9121 FORMAT (10X,' LENTRY=',I9,' NWTAB,NWBANK=',I5,I7)
229
230#endif
231#if defined(CERNLIB_FZFFNAT)
232 IF (IFIFOX.EQ.0) THEN
233 CALL FZOFFN (IUHEAD)
234 IF (IQUEST(7).EQ.1) ISTTAB = 1
235 GO TO 124
236 ENDIF
237#endif
238#if defined(CERNLIB_FZMEMORY)
239 IF (IFIFOX.EQ.3) THEN
240 IF (NWMEMT.GT.IQ(KQSP+LQFX+9)) GO TO 909
241 ENDIF
242#endif
243 CALL FZOFFX (IUHEAD)
244 124 IQ(KQSP+LQFX+15) = IQ(KQSP+LQFX+15) + 1
245 IFSENT = 7
246
247 IACTVX = 12
248 IF (NWBKX.EQ.0) GO TO 190
249
250C------ Copy table and bank material
251
252 IQ(KQSP+LQFI+16) = IQ(KQSP+LQFI+16) + 1
253 IQ(KQSP+LQFX+16) = IQ(KQSP+LQFX+16) + 1
254
255 IQUEST(7) = ISTTAB
256 IDX(2) = 0
257#if defined(CERNLIB_FZFFNAT)
258 IF (IFIFOI.EQ.0) THEN
259 CALL FZCFFN
260 GO TO 189
261 ENDIF
262#endif
263 CALL FZCFFX
264 189 IF (JRETCD.NE.0) GO TO 971
265 GO TO 191
266
267C---- Test for pseudo end-of-tape
268
269 190 IQ(KQSP+LQFX+17) = IQ(KQSP+LQFX+17) + 1
270 LRTYP = 0
271 191 NUM1 = IQ(KQSP+LQFX+19)
272 NUM2 = IQ(KQSP+LQFX+20)
273 192 IF (NUM2.GE.1000000) THEN
274 NUM1 = NUM1 + 1
275 NUM2 = NUM2 - 1000000
276 IQ(KQSP+LQFX+19) = NUM1
277 IQ(KQSP+LQFX+20) = NUM2
278 GO TO 192
279 ENDIF
280
281 LIM1 = IQ(KQSP+LQFX+37)
282 LIM2 = IQ(KQSP+LQFX+38)
283
284 IF (LIM1+LIM2.EQ.0) GO TO 991
285 IF (NUM1-LIM1) 991, 196, 197
286 196 IF (NUM2.LT.LIM2) GO TO 991
287
288 197 IQUEST(1) = 1
289 GO TO 992
290
291C-------------------------------------------------
292C- ERROR HANDLING
293C-------------------------------------------------
294
295 901 IF (IACTVX.EQ.17) CALL ZFATAM ('FZCOPY - Going beyond EoD.')
296 IACTVX = 17
297 GO TO 929
298
299 903 IQUEST(11) = IOCHX(1)
300 CALL ZFATAM ('FZCOPY - IOCH invalid.')
301
302#if defined(CERNLIB_FZCHANNEL)||defined(CERNLIB_FZMEMORY)
303 907 IQUEST(11) = LUNX
304 CALL ZFATAM ('FZCOPY - User routine / buffer not connected.')
305
306#endif
307#if defined(CERNLIB_FZMEMORY)
308 909 IQUEST(2) = 14
309 IQUEST(8) = IQ(KQSP+LQFX+9)
310 IQUEST(9) = NWMEMT
311 IQUEST(11) = LUNX
312 IF (NEWOPT(3).EQ.0) CALL ZTELL (14,1)
313#endif
314 929 IQUEST(1) = 2
315 GO TO 998
316
317C- JERROR = 409 input not positioned
318 949 JERROR = 4
319
320C- JERROR = 404 Alfa mode not allowed
321 944 JERROR = JERROR + 1
322
323C- JERROR = 403 input/output both channel mode
324 943 JERROR = JERROR + 1
325
326C- JERROR = 402 native input record length too long
327 942 JERROR = JERROR + 1
328
329C- JERROR = 401 input/output different data format
330 941 JERROR = 401 + JERROR
331 IF (NEWOPT(3).EQ.0) NEWOPT(3)=-1
332 JRETCD = 4
333
334C------- Input errors
335
336C-- write emergency stop signal
337
338 971 IF (IFSENT.EQ.0) GO TO 974
339 IDX(2) = 9
340#if defined(CERNLIB_FZFFNAT)
341 IF (IFIFOX.EQ.0) THEN
342 CALL FZON1 (9,1)
343 GO TO 972
344 ENDIF
345#endif
346 CALL FZOREC
347 972 IACTVX = 12
348
349 974 CALL FZIDIA
350 IQ(KQSP+LQFI+26) = IQUEST(1)
351 IF (NEWOPT(3).LT.0) CALL ZFATAL
352 GO TO 997
353
354C-------------------------------------------------
355C- COMMON EXIT
356C-------------------------------------------------
357
358 991 IQUEST(1) = 0
359 992 IQUEST(2) = 0
360 IQUEST(5) = IQ(KQSP+LQFX+31)
361 IQUEST(6) = IQ(KQSP+LQFX+32)
362#if defined(CERNLIB_FZMEMORY)
363 IF (IFIFOX.EQ.3)
364 +IQUEST(9) = IQ(KQSP+LQFX+1) - IQ(KQSP+LQFX+8)
365#endif
366 IQUEST(10) = NWMEMT
367 IQUEST(11) = NWBKX
368 IQUEST(12) = NWTABX
369 IQUEST(13) = IQ(KQSP+LQFX+15)
370 IQUEST(14) = IQ(KQSP+LQFX+19)
371 IQUEST(15) = IQ(KQSP+LQFX+20)
372 IQUEST(16) = IQ(KQSP+LQFX+21)
373 IQUEST(17) = IQ(KQSP+LQFX+22)
374
375C-- update the input control bank
376 IQ(KQSP+LQFI+26) = 0
377 997 IQ(KQSP+LQFI+2) = IACTVI
378 IQ(KQSP+LQFI+20) = NWRDAI
379 IQ(KQSP+LQFI+21) = NRECAI
380 IQ(KQSP+LQFI+27) = LRTYP
381 998 IQ(KQSP+LQFX+2) = IACTVX
382#include "zebra/qtrace99.inc"
383 RETURN
384 END
385* ==================================================
386#include "zebra/qcardl.inc"