[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / fq / fzoasc.F

*
* $Id$
*
* $Log$
* Revision 1.2  1996/04/18 16:10:45  mclareni
* Incorporate changes from J.Zoll for version 3.77
*
* Revision 1.1.1.1  1996/03/06 10:47:14  mclareni
* Zebra
*
*
#include "zebra/pilot.h"
#if defined(CERNLIB_FZALFA)
      SUBROUTINE FZOASC (LUNP,LBUFAP,LBUFEP,JFAST,LWORKA,LWORKE)

C-    Dump one physical record to cards in ALFA mode,
C-    service routine to FZOUT.

C-    The record is stored in words LQ(LBUFA) to LQ(LBUFE-1)
C-    It is a 'fast' record if JFAST .NE. 0
C-    The working space available to FZOASC
C-       is  LQ(LWORKA) to LQ(LWORKE)  if LWORKE .NE. 0
C-       or  LQ(LWORKA) to LQ(LBUFC)   if LWORKE .EQ. 0

#include "zebra/zbcd.inc"
#include "zebra/zkrakc.inc"
#include "zebra/zstate.inc"
#include "zebra/zunit.inc"
#include "zebra/mqsysh.inc"
C--------------    End CDE                             --------------
      DIMENSION    LUNP(9), LBUFAP(9), LBUFEP(9)

      DIMENSION MTYPTR(7), ICHSUM(2)
      EQUIVALENCE  (LUN ,IQUEST(90))
      EQUIVALENCE  (JPUT,IQUEST(91)), (IFLEND,IQUEST(92))
      EQUIVALENCE (LUPKA,IQUEST(93)), (LUPKE, IQUEST(94))

#if defined(CERNLIB_QMVDS)
      SAVE         MTYPTR
#endif
#if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
      DIMENSION    NAMESR(2)
      DATA  NAMESR / 4HFZOA, 4HSC   /
#endif
#if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
      DATA  NAMESR / 6HFZOASC  /
#endif
#if !defined(CERNLIB_QTRHOLL)
      CHARACTER    NAMESR*8
      PARAMETER   (NAMESR = 'FZOASC  ')
#endif
      DATA  MTYPTR / 0, 0, 5, 10, 15, 20, 36 /

#include "zebra/q_jbyt.inc"

#include "zebra/qtraceq.inc"

      LUN   = LUNP(1)
      LBUFA = LBUFAP(1)
      LBUFE = LBUFEP(1)
      LWKA  = LWORKA
      LWKE  = LWORKE

      LUPKA = LWKA
      LUPKE = LWKE
      NWWKU = LWKE - LWKA
      IF (LUPKE.EQ.0)  THEN
          LUPKE = LBUFA
          NWWKU = 0
        ENDIF

      IQCETK(1) = IQGREA
      IQCETK(2) = 58
      IF (JFAST.EQ.0)  THEN
          IQCETK(3) = 27
          LBUFC = LBUFA + 4
        ELSE
          IQCETK(3) = 26
          LBUFC = LBUFA
        ENDIF
      JPUT   = 3
      IFLEND = 0
      ITYPE  = 0
      ITYPC  = -1

      ICHSUM(1) = 0
      ICHSUM(2) = 0
      GO TO 40

C--------          Do next word

   31 IWORD = LQ(LBUFC)
   32 JTYPE = LQ(LUPK)
      IF (JTYPE.LT.0)              GO TO 61
#if defined(CERNLIB_QDEVZE)
      IF (NQDEVZ.GE.9)  THEN
          WRITE (IQLOG,9832) LBUFC+1-LBUFA,IWORD,(LQ(LUPK+J),J=0,9)
          DO  33  J=0,7
          IF (IABS(LQ(LUPK+J)).GT.99)  WRITE (IQLOG,9833) LQ(LUPK+J)
   33     CONTINUE
        ENDIF

#endif
#if (defined(CERNLIB_QDEVZE))&&(defined(CERNLIB_B32))
 9832 FORMAT (' DEVZE FZOASC, do word',I4,Z9,' Upk=',8I3,' Next',2I5)
 9833 FORMAT (22X,Z9)
#endif
#if (defined(CERNLIB_QDEVZE))&&(!defined(CERNLIB_B32))
 9832 FORMAT (' DEVZE FZOASC, do word',I4,Z17,' Upk=',8I3,' Next',2I5)
 9833 FORMAT (22X,Z17)

#endif
      JTYPS = LQ(LUPK+1)
      JTYPC = MTYPTR(JTYPE+1) + JTYPS

C--       same type running
      IF (JTYPC.EQ.ITYPC)          GO TO 36

C--                M-type 0 : integers 0 -> 9

      IF (JTYPE.NE.0)              GO TO 41
      IF (ITYPC.EQ.24)             GO TO 36
      JBA = 0

C------            Store next word

C--       terminate running type by ']', if any
   34 IF (ITYPE.NE.0) THEN
          JPUT = JPUT + 1
          IQCETK(JPUT) = 53
          ITYPE = 0
          ITYPC = -1
        ENDIF

C--       place type-code
   35 JPUT = JPUT + 1
      IQCETK(JPUT) = JTYPC
      IF (JBA.EQ.0)                GO TO 38

C--       place significant bytes
   36 DO 37  J=JBA,JBE
      JPUT = JPUT + 1
   37 IQCETK(JPUT) = LQ(LUPK+J)
   38 LUPK = LUPK + 8

C--       put blank separator for tests
#if defined(CERNLIB_FQABLANK)
      JPUT = JPUT + 1
      IQCETK(JPUT) = 44
#endif

C--                Cumulate check-sum

      ICHSUM(1) = ICHSUM(1) + JBYT (IWORD,17,16)
      ICHSUM(2) = ICHSUM(2) + JBYT (IWORD, 1,16)

C--                Write line if full

      IF (JPUT.GE.80)   CALL FZOALN

C--                End-of-record ?

      LBUFC = LBUFC + 1
      IF (LBUFC.EQ.LBUFE)          GO TO 81

C--                Unpack the next lot, if necc.

      IF (LUPK.LT.LUPKE)           GO TO 31

      IF (NWWKU.NE.0)  THEN
          IF (NWWKU.GE.LBUFC-LBUFA) THEN
              LUPKE = LWKE
            ELSE
              LUPKA = LBUFA
              LUPKE = LBUFC
            ENDIF
        ELSE
          LUPKE = LBUFC
        ENDIF

   40 LUPKEL = LUPKE
      CALL FZOAPK (LBUFC,LBUFE)
      LUPK = LUPKA
      GO TO 31

C------            Type analysis
C-                 come to here if the type of the current word
C-                 is not the one of the running set, and if
C-                 the current M-type is not zero


   41 NTYPE = LQ(LUPK+8)
      NTYPS = LQ(LUPK+9)
      NTYPC = -2
      IF (NTYPE.GE.0)  NTYPC = MTYPTR(NTYPE+1) + NTYPS

C--                Check next word after current has again ITYPC
C-                 and ITYPC covers JTYPC with 1 or 2 zero bytes

      IF (JTYPE.NE.ITYPE)          GO TO 51
      IF (NTYPC.NE.ITYPC)          GO TO 51
      N = JTYPC - ITYPC
      IF (N.LT.0)                  GO TO 51
      IF (N.LT.3)                  GO TO 36

C----              The running set is definitely not continued

   51 IF (JTYPE.LT.5)  THEN
          JBA = 2
          JBE = 7 - JTYPS
        ELSE
          JBA = 3 + JTYPS
          JBE = 7
        ENDIF

C----              Start of a new set if this and the next
C-                 two numbers are of the same type

      IF (NTYPC.NE.JTYPC)          GO TO 34
      IF (LUPK+16.GE.LUPKE)        GO TO 34
      IF (LQ(LUPK+16).NE.JTYPE)    GO TO 34
      IF (LQ(LUPK+17).NE.JTYPS)    GO TO 34

      ITYPE = JTYPE
      ITYPC = JTYPC
      JPUT  = JPUT + 1
      IQCETK(JPUT) = 57
      GO TO 35

C------            Repeat last number N+1 times

   61 CONTINUE
#if defined(CERNLIB_QDEVZE)
      IF (JTYPE.NE.-43)  CALL ZFATAM ('FZOASC - trouble.')
#endif
      JPUT = JPUT + 1
      IQCETK(JPUT) = 43

      LUPK  = LUPK + 1
      IWORD = LQ(LUPK)
      LBUFC = LBUFC + IWORD
#if defined(CERNLIB_QDEVZE)
      LUPKEL = LUPKEL - 4
      LUPK   = LUPKEL
      LQ(LUPK) = IWORD
#endif

      LUPKE = LUPKEL
      CALL FZOAPK (LUPK,LUPK+1)
   68 LUPK  = LUPKA
      ITYPE = 0
      ITYPC = -1
      GO TO 32

C--------          End of record

   81 IF (IFLEND.NE.0)             GO TO 84
      JPUT = JPUT + 1
      IQCETK(JPUT) = 59
      LST   = LUPKA
      LUPKA = LUPKA + 2
      LUPKE = LUPKEL

      LQ(LST)   = ICHSUM(1)
      LQ(LST+1) = ICHSUM(2)
      CALL FZOAPK (LST,LST+2)

      IFLEND = -1
      LBUFC  = LBUFE - 1
      IWORD  = ICHSUM(1)
      GO TO 68

   84 IF (IFLEND.NE.-1)            GO TO 86
      IFLEND = -2
      LBUFC  = LBUFE - 1
      IWORD  = LQ(LST+1)
      GO TO 32

   86 IFLEND = 7
      CALL FZOALN

#include "zebra/qtrace99.inc"
      RETURN
      END
*      ==================================================
#include "zebra/qcardl.inc"
#endif
Commit	Line	Data
fe4da5cc	1	*
	2	* $Id$
	3	*
	4	* $Log$
	5	* Revision 1.2 1996/04/18 16:10:45 mclareni
	6	* Incorporate changes from J.Zoll for version 3.77
	7	*
	8	* Revision 1.1.1.1 1996/03/06 10:47:14 mclareni
	9	* Zebra
	10	*
	11	*
	12	#include "zebra/pilot.h"
	13	#if defined(CERNLIB_FZALFA)
	14	SUBROUTINE FZOASC (LUNP,LBUFAP,LBUFEP,JFAST,LWORKA,LWORKE)
	15
	16	C- Dump one physical record to cards in ALFA mode,
	17	C- service routine to FZOUT.
	18
	19	C- The record is stored in words LQ(LBUFA) to LQ(LBUFE-1)
	20	C- It is a 'fast' record if JFAST .NE. 0
	21	C- The working space available to FZOASC
	22	C- is LQ(LWORKA) to LQ(LWORKE) if LWORKE .NE. 0
	23	C- or LQ(LWORKA) to LQ(LBUFC) if LWORKE .EQ. 0
	24
	25	#include "zebra/zbcd.inc"
	26	#include "zebra/zkrakc.inc"
	27	#include "zebra/zstate.inc"
	28	#include "zebra/zunit.inc"
	29	#include "zebra/mqsysh.inc"
	30	C-------------- End CDE --------------
	31	DIMENSION LUNP(9), LBUFAP(9), LBUFEP(9)
	32
	33	DIMENSION MTYPTR(7), ICHSUM(2)
	34	EQUIVALENCE (LUN ,IQUEST(90))
	35	EQUIVALENCE (JPUT,IQUEST(91)), (IFLEND,IQUEST(92))
	36	EQUIVALENCE (LUPKA,IQUEST(93)), (LUPKE, IQUEST(94))
	37
	38	#if defined(CERNLIB_QMVDS)
	39	SAVE MTYPTR
	40	#endif
	41	#if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
	42	DIMENSION NAMESR(2)
	43	DATA NAMESR / 4HFZOA, 4HSC /
	44	#endif
	45	#if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
	46	DATA NAMESR / 6HFZOASC /
	47	#endif
	48	#if !defined(CERNLIB_QTRHOLL)
	49	CHARACTER NAMESR*8
	50	PARAMETER (NAMESR = 'FZOASC ')
	51	#endif
	52	DATA MTYPTR / 0, 0, 5, 10, 15, 20, 36 /
	53
	54	#include "zebra/q_jbyt.inc"
	55
	56	#include "zebra/qtraceq.inc"
	57
	58	LUN = LUNP(1)
	59	LBUFA = LBUFAP(1)
	60	LBUFE = LBUFEP(1)
	61	LWKA = LWORKA
	62	LWKE = LWORKE
	63
	64	LUPKA = LWKA
65	LUPKE = LWKE
66	NWWKU = LWKE - LWKA
67	IF (LUPKE.EQ.0) THEN
68	LUPKE = LBUFA
69	NWWKU = 0
70	ENDIF
71
72	IQCETK(1) = IQGREA
73	IQCETK(2) = 58
74	IF (JFAST.EQ.0) THEN
75	IQCETK(3) = 27
76	LBUFC = LBUFA + 4
77	ELSE
78	IQCETK(3) = 26
79	LBUFC = LBUFA
80	ENDIF
81	JPUT = 3
82	IFLEND = 0
83	ITYPE = 0
84	ITYPC = -1
85
86	ICHSUM(1) = 0
87	ICHSUM(2) = 0
88	GO TO 40
89
90	C-------- Do next word
91
92	31 IWORD = LQ(LBUFC)
93	32 JTYPE = LQ(LUPK)
94	IF (JTYPE.LT.0) GO TO 61
95	#if defined(CERNLIB_QDEVZE)
96	IF (NQDEVZ.GE.9) THEN
97	WRITE (IQLOG,9832) LBUFC+1-LBUFA,IWORD,(LQ(LUPK+J),J=0,9)
98	DO 33 J=0,7
99	IF (IABS(LQ(LUPK+J)).GT.99) WRITE (IQLOG,9833) LQ(LUPK+J)
100	33 CONTINUE
101	ENDIF
102
103	#endif
104	#if (defined(CERNLIB_QDEVZE))&&(defined(CERNLIB_B32))
105	9832 FORMAT (' DEVZE FZOASC, do word',I4,Z9,' Upk=',8I3,' Next',2I5)
106	9833 FORMAT (22X,Z9)
107	#endif
108	#if (defined(CERNLIB_QDEVZE))&&(!defined(CERNLIB_B32))
109	9832 FORMAT (' DEVZE FZOASC, do word',I4,Z17,' Upk=',8I3,' Next',2I5)
110	9833 FORMAT (22X,Z17)
111
112	#endif
113	JTYPS = LQ(LUPK+1)
114	JTYPC = MTYPTR(JTYPE+1) + JTYPS
115
116	C-- same type running
117	IF (JTYPC.EQ.ITYPC) GO TO 36
118
119	C-- M-type 0 : integers 0 -> 9
120
121	IF (JTYPE.NE.0) GO TO 41
122	IF (ITYPC.EQ.24) GO TO 36
123	JBA = 0
124
125	C------ Store next word
126
127	C-- terminate running type by ']', if any
128	34 IF (ITYPE.NE.0) THEN
129	JPUT = JPUT + 1
130	IQCETK(JPUT) = 53
131	ITYPE = 0
132	ITYPC = -1
133	ENDIF
134
135	C-- place type-code
136	35 JPUT = JPUT + 1
137	IQCETK(JPUT) = JTYPC
138	IF (JBA.EQ.0) GO TO 38
139
140	C-- place significant bytes
141	36 DO 37 J=JBA,JBE
142	JPUT = JPUT + 1
143	37 IQCETK(JPUT) = LQ(LUPK+J)
144	38 LUPK = LUPK + 8
145
146	C-- put blank separator for tests
147	#if defined(CERNLIB_FQABLANK)
148	JPUT = JPUT + 1
149	IQCETK(JPUT) = 44
150	#endif
151
152	C-- Cumulate check-sum
153
154	ICHSUM(1) = ICHSUM(1) + JBYT (IWORD,17,16)
155	ICHSUM(2) = ICHSUM(2) + JBYT (IWORD, 1,16)
156
157	C-- Write line if full
158
159	IF (JPUT.GE.80) CALL FZOALN
160
161	C-- End-of-record ?
162
163	LBUFC = LBUFC + 1
164	IF (LBUFC.EQ.LBUFE) GO TO 81
165
166	C-- Unpack the next lot, if necc.
167
168	IF (LUPK.LT.LUPKE) GO TO 31
169
170	IF (NWWKU.NE.0) THEN
171	IF (NWWKU.GE.LBUFC-LBUFA) THEN
172	LUPKE = LWKE
173	ELSE
174	LUPKA = LBUFA
175	LUPKE = LBUFC
176	ENDIF
177	ELSE
178	LUPKE = LBUFC
179	ENDIF
180
181	40 LUPKEL = LUPKE
182	CALL FZOAPK (LBUFC,LBUFE)
183	LUPK = LUPKA
184	GO TO 31
185
186	C------ Type analysis
187	C- come to here if the type of the current word
188	C- is not the one of the running set, and if
189	C- the current M-type is not zero
190
191
192	41 NTYPE = LQ(LUPK+8)
193	NTYPS = LQ(LUPK+9)
194	NTYPC = -2
195	IF (NTYPE.GE.0) NTYPC = MTYPTR(NTYPE+1) + NTYPS
196
197	C-- Check next word after current has again ITYPC
198	C- and ITYPC covers JTYPC with 1 or 2 zero bytes
199
200	IF (JTYPE.NE.ITYPE) GO TO 51
201	IF (NTYPC.NE.ITYPC) GO TO 51
202	N = JTYPC - ITYPC
203	IF (N.LT.0) GO TO 51
204	IF (N.LT.3) GO TO 36
205
206	C---- The running set is definitely not continued
207
208	51 IF (JTYPE.LT.5) THEN
209	JBA = 2
210	JBE = 7 - JTYPS
211	ELSE
212	JBA = 3 + JTYPS
213	JBE = 7
214	ENDIF
215
216	C---- Start of a new set if this and the next
217	C- two numbers are of the same type
218
219	IF (NTYPC.NE.JTYPC) GO TO 34
220	IF (LUPK+16.GE.LUPKE) GO TO 34
221	IF (LQ(LUPK+16).NE.JTYPE) GO TO 34
222	IF (LQ(LUPK+17).NE.JTYPS) GO TO 34
223
224	ITYPE = JTYPE
225	ITYPC = JTYPC
226	JPUT = JPUT + 1
227	IQCETK(JPUT) = 57
228	GO TO 35
229
230	C------ Repeat last number N+1 times
231
232	61 CONTINUE
233	#if defined(CERNLIB_QDEVZE)
234	IF (JTYPE.NE.-43) CALL ZFATAM ('FZOASC - trouble.')
235	#endif
236	JPUT = JPUT + 1
237	IQCETK(JPUT) = 43
238
239	LUPK = LUPK + 1
240	IWORD = LQ(LUPK)
241	LBUFC = LBUFC + IWORD
242	#if defined(CERNLIB_QDEVZE)
243	LUPKEL = LUPKEL - 4
244	LUPK = LUPKEL
245	LQ(LUPK) = IWORD
246	#endif
247
248	LUPKE = LUPKEL
249	CALL FZOAPK (LUPK,LUPK+1)
250	68 LUPK = LUPKA
251	ITYPE = 0
252	ITYPC = -1
253	GO TO 32
254
255	C-------- End of record
256
257	81 IF (IFLEND.NE.0) GO TO 84
258	JPUT = JPUT + 1
259	IQCETK(JPUT) = 59
260	LST = LUPKA
261	LUPKA = LUPKA + 2
262	LUPKE = LUPKEL
263
264	LQ(LST) = ICHSUM(1)
265	LQ(LST+1) = ICHSUM(2)
266	CALL FZOAPK (LST,LST+2)
267
268	IFLEND = -1
269	LBUFC = LBUFE - 1
270	IWORD = ICHSUM(1)
271	GO TO 68
272
273	84 IF (IFLEND.NE.-1) GO TO 86
274	IFLEND = -2
275	LBUFC = LBUFE - 1
276	IWORD = LQ(LST+1)
277	GO TO 32
278
279	86 IFLEND = 7
280	CALL FZOALN
281
282	#include "zebra/qtrace99.inc"
283	RETURN
284	END
285	* ==================================================
286	#include "zebra/qcardl.inc"
287	#endif