]> git.uio.no Git - u/mrichter/AliRoot.git/blame - MINICERN/packlib/zebra/tq/tzfree.F
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Bugfix in AliPoints2Memory
[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / tq / tzfree.F
CommitLineData
fe4da5cc 1*
2* $Id$
3*
4* $Log$
5* Revision 1.2 1996/04/18 16:14:52 mclareni
6* Incorporate changes from J.Zoll for version 3.77
7*
8* Revision 1.1.1.1 1996/03/06 10:47:27 mclareni
9* Zebra
10*
11*
12#include "zebra/pilot.h"
13 SUBROUTINE TZFREE
14
15C-- Read 1 title bank in free field format for TZINIT
16
17#include "zebra/zmach.inc"
18#include "zebra/zstate.inc"
19#include "zebra/zunit.inc"
20#include "zebra/mqsys.inc"
21#include "zebra/eqlqt.inc"
22#include "zebra/tzuc.inc"
23#include "zebra/tzc1.inc"
24C-------------- END CDE -----------------
25 COMMON /SLATE/ NDSLAT,NESLAT,NFSLAT,NGSLAT,NUM(2),DUMMY(34)
26 CHARACTER COL(LGL)*1
27 EQUIVALENCE (COL(1), LINE(1:1))
28
29 CHARACTER CHTYP*(*), FAULT*20
30 PARAMETER (CHTYP = '#''":')
31
32
33 IF (JCOLA.EQ.0) JCOLA = 1
34 IF (JCOLE.EQ.0) JCOLE = LGL
35 IF (NCHPW.EQ.0) NCHPW = 4
36 IPRHEA = IFLLOG
37 NREADY = 7
38 MULT = 0
39 LPUTX = LPUTA
40
41C-- Print delimitation, unless full line
42
43 IF (IFLPRI.EQ.0) GO TO 21
44 IF (JCOLE.EQ.LGL) THEN
45 IF (JCOLA.EQ.1) GO TO 21
46 WRITE (IQLOG,9016) BLANK(1:JCOLA)
47 ELSE
48 NB = JCOLE-1 - JCOLA
49 IF (NB.GE.3) THEN
50 WRITE (IQLOG,9016) BLANK(1:JCOLA), BLANK(1:NB-2)
51 ELSE
52 WRITE (IQLOG,9017) BLANK(1:JCOLA), BLANK(1:NB)
53 ENDIF
54 ENDIF
55
56 9016 FORMAT (5X,A,'<-',A,'->')
57 9017 FORMAT (5X,A,'<',A,'>')
58
59C---- Read line by line
60
61 21 CONTINUE
62#include "zebra/tzread1.inc"
63
64 IF (COL(1).EQ.'*') RETURN
65
66 IF (IFLPRI.NE.0) WRITE (IQLOG,9001) LINE(1:NCHORG)
67 9001 FORMAT (6X,A)
68
69
70C------ Crack field by field
71
72 JSTATE = 0
73 JTKEND = MIN (NCHORG,JCOLE)
74 JTKE = JCOLA - 1
75 24 J = ICNEXT (LINE,JTKE+1,JTKEND)
76 IF (J.GT.JTKEND) THEN
77 IF (MULT.NE.0) GO TO 82
78 GO TO 21
79 ENDIF
80
81 JTKA = J
82 JTKE = NESLAT - 1
83 NTK = NDSLAT
84
85 JTYP = INDEX (CHTYP,COL(JTKA)) + 1
86 GO TO (61, 31, 41, 41, 43), JTYP
87C- 1 2 3 4 5
88C- numeric # ' " :
89
90C---- # item
91
92 31 IF (NTK.LT.2) GO TO 81
93 JIT = INDEX ('.ADNadnOo0Xx', COL(JTKA+1))
94C- 123456789012
95 IF (JIT.EQ.0) GO TO 81
96 IF (JIT.GE.8) GO TO 61
97 IF (JIT.GE.5) JIT = JIT - 3
98 IF (MULT.NE.0) GO TO 82
99
100C-- #. comment #
101 IF (JIT.EQ.1) THEN
102 JTKE = ICFIND ('#', LINE,JTKA+2,JTKEND)
103 GO TO 24
104 ENDIF
105
106C-- #AnCW control item
107 IF (JIT.EQ.2) THEN
108 CALL TZACW (LINE(JTKA+1:JTKE))
109 IF (NCHPW.GE.0) GO TO 24
110 NCHPW = 4
111 GO TO 81
112 ENDIF
113
114C-- #Double control item
115 IF (JIT.EQ.3) THEN
116 IFLDBL = 1
117 GO TO 24
118 ENDIF
119
120C-- #Normal control item
121 IFLDBL = 0
122 GO TO 24
123
124C---- Handling Hollerith
125
126 41 JTKE = ICFIND (COL(JTKA), LINE,JTKA+1,JTKEND)
127 IF (JTKE.GT.JTKEND) GO TO 83
128 NTK = JTKE - JTKA
129
130 43 JTKA = JTKA + 1
131 NTK = NTK - 1
132
133 NWDH = (NTK-1) / NCHPW + 1
134 NWDS = NWDH + IFLHC + IFLHW
135 NWDT = NWDS
136 IF (MULT.NE.0) NWDT = NWDT * MULT
137 IF (LPUTX+NWDT.GT.LPUTE) GO TO 84
138
139 JST = LPUTX
140 IF (IFLHC.NE.0) THEN
141 LQ(JST) = NTK
142 JST = JST + 1
143 ENDIF
144
145 IF (IFLHW.NE.0) THEN
146 LQ(JST) = NWDH
147 JST = JST + 1
148 ENDIF
149
150 CALL UCTOH (LINE(JTKA:JTKE), LQ(JST),NCHPW, NTK)
151
152 JST = LPUTX
153 LPUTX = LPUTX + NWDT
154 IF (MULT.EQ.0) GO TO 24
155
156 MULT = MULT - 1
157 CALL UCOCOP (LQ(JST),LQ(JST+NWDS),MULT,NWDS,0,NWDS)
158 MULT = 0
159 GO TO 24
160
161C---- Handle numeric
162
163 61 CALL CKRACK (LINE,JTKA,JTKE,IFLDBL)
164 IF (NFSLAT.LE.0) GO TO 86
165 IF (NGSLAT.NE.0) GO TO 67
166 NWDS = MAX (1, NFSLAT-2)
167 NWDT = NWDS
168 IF (MULT.NE.0) NWDT = NWDT * MULT
169 IF (LPUTX+NWDT.GT.LPUTE) GO TO 84
170
171 JST = LPUTX
172 LPUTX = LPUTX + NWDT
173 IF (MULT.NE.0) GO TO 64
174
175 LQ(JST) = NUM(1)
176 IF (NWDS.EQ.1) GO TO 24
177 LQ(JST+1) = NUM(2)
178 GO TO 24
179
180 64 IF (NWDS.EQ.1) THEN
181 CALL VFILL (LQ(JST),MULT,NUM(1))
182 ELSE
183 CALL UCOCOP (NUM,LQ(JST),MULT,NWDS,0,NWDS)
184 ENDIF
185 MULT = 0
186 GO TO 24
187
188C-- handle repeat*
189
190 67 JE = NESLAT
191 IF (COL(JE).NE.'*') GO TO 86
192 IF (NFSLAT.GE.3) GO TO 81
193 IF (MULT.NE.0) GO TO 82
194 IF (NUM(1).LE.1) GO TO 85
195 MULT = NUM(1)
196 JTKE = JE
197 GO TO 24
198
199C---- EoF seen
200
201 78 NREADY = -7
202 RETURN
203
204C---- Error handling
205
206C- 81 : nothing special
207C- 82 : pending repeat not allowed
208C- 83 : missing terminator " or '
209C- 84 : more data than expected
210C- 85 : invalid repeat count
211C- 86 : invalid numeric
212
213 86 JSTATE = 1
214 JTKA = NESLAT
215 85 JSTATE = JSTATE + 1
216 84 JSTATE = JSTATE + 1
217 83 JSTATE = JSTATE + 1
218 82 JSTATE = JSTATE + 1
219 81 JSTATE = JSTATE + 1
220
221 IF (IFLPRI.EQ.0) THEN
222 IF (IPRHEA.EQ.0) THEN
223 WRITE (IQLOG,9012) LHEAD(1:NHEAD)
224 IPRHEA = 7
225 ENDIF
226 WRITE (IQLOG,9001) LINE(1:JTKEND)
227 ENDIF
228
229 IF (JSTATE.EQ.1) THEN
230 FAULT = 'fault'
231 ELSEIF (JSTATE.EQ.2) THEN
232 FAULT = 'pending repeat'
233 ELSEIF (JSTATE.EQ.3) THEN
234 FAULT = 'missing terminator'
235 ELSEIF (JSTATE.EQ.4) THEN
236 FAULT = 'too much data'
237 ELSEIF (JSTATE.EQ.5) THEN
238 FAULT = 'invalid repeat count'
239 ELSEIF (JSTATE.EQ.6) THEN
240 FAULT = 'invalid'
241 ENDIF
242
243 WRITE (IQLOG,9091) BLANK(1:JTKA),FAULT
244 NFAULT = NFAULT + 1
245 MULT = 0
246 IF (JSTATE.NE.4) GO TO 21
247 NREADY = 0
248 RETURN
249
250 9012 FORMAT (3X,' > ',A)
251 9091 FORMAT (' !!f',A,'^-> !!! ',A)
252 END
253* ==================================================
254#include "zebra/qcardl.inc"