This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / GEANT321 / giopa / gfout.F
1 *
2 * $Id$
3 *
4 * $Log$
5 * Revision 1.1.1.1  1995/10/24 10:21:16  cernlib
6 * Geant
7 *
8 *
9 #include "geant321/pilot.h"
10 *CMZ :  3.21/02 29/03/94  15.41.20  by  S.Giani
11 *-- Author :
12       SUBROUTINE GFOUT(LUN,CHOBJ,NKEYS,IDVERS,CHOPT,IER)
13 C.
14 C.    ******************************************************************
15 C.    *                                                                *
16 C.    *       Routine to write GEANT object(s) into the FZ file        *
17 C.    *       The data structures in memory are written on disk        *
18 C.    *                                                                *
19 C.    *       LUN    Logical unit                                      *
20 C.    *                                                                *
21 C.    *       CHOBJ  The type of data structure to be written:         *
22 C.    *              MATE material                                     *
23 C.    *              TMED tracking medium                              *
24 C.    *              VOLU volumes                                      *
25 C.    *              ROTM rotation matrix                              *
26 C.    *              SETS detector set                                 *
27 C.    *              PART particle                                     *
28 C.    *              SCAN geometry                                     *
29 C.    *              INIT all above                                    *
30 C.    *              KINE this keyword will trigger the write of       *
31 C.    *                   KINE and VERT unless the flag 'S' is set     *
32 C.    *              DIGI digitisation                                 *
33 C.    *              DRAW drawing                                      *
34 C.    *              HEAD event header                                 *
35 C.    *              HITS hits                                         *
36 C.    *              RUNG run                                          *
37 C.    *              STAK particle temporary stack                     *
38 C.    *              STAT volume statistic                             *
39 C.    *              VERT vertex                                       *
40 C.    *              JXYZ track points                                 *
41 C.    *              TRIG this keyword will trigger the write of       *
42 C.    *                   DIGI, HEAD, HITS, KINE, VERT abd JXYZ        *
43 C.    *                   unless the 'S' flag is set                   *
44 C.    *                                                                *
45 C.    *       NKEYS  number of keys in vector CHOBJ                    *
46 C.    *                                                                *
47 C.    *       IDVERS version of the data structure to be written out   *
48 C.    *                                                                *
49 C.    *       CHOPT  List of options                                   *
50 C.    *                   'I'      write only initialisation data      *
51 C.    *                            structures                          *
52 C.    *                   'K'      write only KINE and TRIG data       *
53 C.    *                            structures                          *
54 C.    *                   'T'      write only DIGI, HEAD, HITS, KINE,  *
55 C.    *                            VERT and JXYZ data structures       *
56 C.    *              even if other keys are specified in CHOBJ         *
57 C.    *                                                                *
58 C.    *                   'S'       interpret KINE to mean only        *
59 C.    *                             KINE and TRIG and INIT to mean     *
60 C.    *                             nothing                            *
61 C.    *                   'Q'       quiet option, no message is        *
62 C.    *                             printed                            *
63 C.    *                                                                *
64 C.    *       IER    error flag. <0 ZEBRA error flag as returned in    *
65 C.    *                             IQUEST(1)                          *
66 C.    *                           0 read completed successfully        *
67 C.    *                          >0 if only IER structures read in     *
68 C.    *                                                                *
69 C.    *    The FZ data base can be read in via GOPEN/GFIN              *
70 C.    *                                                                *
71 C.    *                                                                *
72 C.    *      Example.                                                  *
73 C.    *                                                                *
74 C.    *      CALL GOPEN(1,'O',1024,IER)                                *
75 C.    *      CALL GFOUT (1,'VOLU',1,0,' ',IER)                         *
76 C.    *      CALL GFOUT (1,'MATE',1,0,' ',IER)                         *
77 C.    *      CALL GFOUT (1,'TMED',1,0,' ',IER)                         *
78 C.    *      CALL GFOUT (1,'ROTM',1,0,' ',IER)                         *
79 C.    *      CALL GFOUT (1,'PART',1,0,' ',IER)                         *
80 C.    *      CALL GFOUT (1,'SCAN',1,0,' ',IER)                         *
81 C.    *      CALL GFOUT (1,'SETS',1,0,' ',IER)                         *
82 C.    *                                                                *
83 C.    *    ==>Called by : <USER> ,GOPEN                                *
84 C.    *       Author    F.Carminati *******                            *
85 C.    *                                                                *
86 C.    ******************************************************************
87 C.
88 #include "geant321/gcbank.inc"
89 #include "geant321/gcflag.inc"
90 #include "geant321/gconsp.inc"
91 #include "geant321/gcnum.inc"
92 #include "geant321/gccuts.inc"
93 #include "geant321/gcscal.inc"
94 #include "geant321/gcdraw.inc"
95 #include "geant321/gcvolu.inc"
96 #include "geant321/gcunit.inc"
97 #include "geant321/gctime.inc"
98 *      COMMON/GCLINK/JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART
99 *     +      ,JROTM ,JRUNG ,JSET  ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX
100 *     +      ,JVOLUM,JXYZ  ,JGPAR ,JGPAR2,JSKLT
101       COMMON/QUEST/IQUEST(100)
102       PARAMETER (NLINIT=9,NLKINE=2,NLTRIG=6,NMKEY=22)
103       DIMENSION JNAMES(20),LINIT(NLINIT),LKINE(NLKINE)
104       DIMENSION LTRIG(NLTRIG),IXD(NMKEY)
105       DIMENSION LINK(NMKEY),IVERSI(NMKEY),LDIV(2),IRESUL(NMKEY)
106       DIMENSION IUHEAD(2),ITRAN(23),JTRAN(23)
107       EQUIVALENCE (JNAMES(1),JDIGI)
108       CHARACTER*4 KNAMES(NMKEY),CHOBJ(*)
109       CHARACTER*(*) CHOPT
110       DATA KNAMES/'DIGI','DRAW','HEAD','HITS','KINE','MATE','PART',
111      +     'ROTM','RUNG','SETS','STAK','STAT','TMED','NULL','VERT',
112      +     'VOLU','JXYZ','NULL','NULL','NULL','SCAN','NULL'/
113       DATA ITRAN/7,6,13,16,8,10,2,9,8*0,3,15,5,17,4,1,21/
114       DATA JTRAN/22,7,17,21,19,2,1,5,8,6,2*0,3,0,18,4,20,3*0,23,2*0/
115       DATA IXD/2,1,2,2,2,8*1,2,2,1,2,3*0,1,0/
116       DATA LINIT/2,6,7,8,9,10,13,16,21/
117       DATA LKINE/5,15/
118       DATA LTRIG/1,3,4,5,15,17/
119 C.
120 C.    ------------------------------------------------------------------
121 C.
122       IQUEST(1)=0
123       IER=0
124       LDIV(1)  =IXCONS
125       LDIV(2)  =IXDIV
126 *
127       IOPTI=INDEX(CHOPT,'i')+INDEX(CHOPT,'I')
128       IOPTT=INDEX(CHOPT,'t')+INDEX(CHOPT,'T')
129       IOPTK=INDEX(CHOPT,'k')+INDEX(CHOPT,'K')
130       IOPTS=INDEX(CHOPT,'s')+INDEX(CHOPT,'S')
131       IOPTQ=INDEX(CHOPT,'q')+INDEX(CHOPT,'Q')
132 *
133       NLINK=0
134       DO 90  JKEY=1,NKEYS
135          IF(IOPTS.EQ.0) THEN
136          IF(CHOBJ(JKEY).EQ.'INIT') THEN
137             DO 20 J=1, NLINIT
138                DO 10  MLINK=1,NLINK
139                   IF(LINK(MLINK).EQ.LINIT(J)) GO TO 20
140    10          CONTINUE
141                NLINK=NLINK+1
142                LINK(NLINK)=LINIT(J)
143    20       CONTINUE
144             GO TO 90
145          ELSEIF(CHOBJ(JKEY).EQ.'TRIG') THEN
146             DO 40 J=1, NLTRIG
147                DO 30  MLINK=1,NLINK
148                   IF(LINK(MLINK).EQ.LTRIG(J)) GO TO 40
149    30          CONTINUE
150                NLINK=NLINK+1
151                LINK(NLINK)=LTRIG(J)
152    40       CONTINUE
153             GO TO 90
154          ELSEIF(CHOBJ(JKEY).EQ.'KINE') THEN
155             DO 60 J=1, NLKINE
156                DO 50  MLINK=1,NLINK
157                   IF(LINK(MLINK).EQ.LKINE(J)) GO TO 60
158    50          CONTINUE
159                NLINK=NLINK+1
160                LINK(NLINK)=LKINE(J)
161    60       CONTINUE
162             GO TO 90
163          ENDIF
164          ENDIF
165             DO 80 J=1,NMKEY
166                IF(CHOBJ(JKEY).EQ.KNAMES(J)) THEN
167                   DO 70 MLINK=1,NLINK
168                      IF(LINK(MLINK).EQ.J) GO TO 90
169    70             CONTINUE
170                   NLINK=NLINK+1
171                   LINK(NLINK)=J
172                   GO TO 90
173                ENDIF
174    80       CONTINUE
175             WRITE(CHMAIL,10300) CHOBJ(JKEY)
176             IF(IOPTQ.EQ.0) CALL GMAIL(0,0)
177    90 CONTINUE
178 *
179       IF(IOPTI.GT.0) THEN
180          DO 110 J=1, NLINK
181             DO 100 K=1, NLINIT
182                IF(LINK(J).EQ.LINIT(K)) GO TO 110
183   100       CONTINUE
184             WRITE(CHMAIL,10000) KNAMES(LINK(J))
185             IF(IOPTQ.EQ.0) CALL GMAIL(0,0)
186             LINK(J)=0
187   110    CONTINUE
188       ELSEIF(IOPTK.GT.0) THEN
189          DO 130 J=1, NLINK
190             DO 120 K=1, NLKINE
191                IF(LINK(J).EQ.LKINE(K)) GO TO 130
192   120       CONTINUE
193             WRITE(CHMAIL,10100) KNAMES(LINK(J))
194             IF(IOPTQ.EQ.0) CALL GMAIL(0,0)
195             LINK(J)=0
196   130    CONTINUE
197       ELSEIF(IOPTT.GT.0) THEN
198          DO 150 J=1, NLINK
199             DO 140 K=1, NLTRIG
200                IF(LINK(J).EQ.LTRIG(K)) GO TO 150
201   140       CONTINUE
202             WRITE(CHMAIL,10200) KNAMES(LINK(J))
203             IF(IOPTQ.EQ.0) CALL GMAIL(0,0)
204             LINK(J)=0
205   150    CONTINUE
206       ENDIF
207 *
208       IOFF=0
209       DO 160 J=1, NLINK
210          IF(LINK(J).EQ.0) THEN
211            IOFF=IOFF-1
212          ELSE
213            LINK(J+IOFF)=LINK(J)
214          ENDIF
215   160 CONTINUE
216       NLINK=NLINK+IOFF
217       IF(IOPTI+IOPTK+IOPTT.EQ.0) THEN
218 *
219 *        We have to choose which event header to write, JRUNG or JHEAD
220 *        If the banks list contains banks which depends on both headers,
221 *        the result is unpredictable. Error message to be inserted later.
222          DO 168 J=1, NLINK
223             DO 161 L=1, NLINIT
224                IF(LINK(J).EQ.LINIT(L)) THEN
225                   IOPTI=-1
226                   GOTO 169
227                ENDIF
228   161       CONTINUE
229             DO 162 L=1, NLKINE
230                IF(LINK(J).EQ.LKINE(L)) THEN
231                   IOPTK=-1
232                   GOTO 169
233                ENDIF
234   162       CONTINUE
235             DO 163 L=1, NLTRIG
236                IF(LINK(J).EQ.LTRIG(L)) THEN
237                   IOPTT=-1
238                   GOTO 169
239                ENDIF
240   163      CONTINUE
241   168    CONTINUE
242   169    CONTINUE
243       ENDIF
244 *
245       IF(NLINK.LE.0) THEN
246          WRITE(CHMAIL,10400)
247          IF(IOPTQ.EQ.0) CALL GMAIL(0,0)
248          IER=-1
249          GOTO 999
250       ENDIF
251 *
252       NWOUT=0
253       IOFW =0
254       DO 170 J=1,NLINK
255          IVERSI(J)=0
256          IRESUL(J)=0
257          NKEY=LINK(J)
258          IF(NKEY.EQ.3.OR.NKEY.EQ.9) THEN
259             IOFW=1
260             NPOS=J
261          ENDIF
262          LINK(J)=-ABS(LINK(J))
263          IF(NKEY.LE.20)THEN
264             IF(JNAMES(NKEY).NE.0) THEN
265                LINK(J)=ABS(LINK(J))
266                NWOUT=NWOUT+1
267             ENDIF
268          ELSE
269             NKL=NKEY-20
270             IF(ISLINK(NKL).NE.0) THEN
271                LINK(J)=ABS(LINK(J))
272                NWOUT=NWOUT+1
273             ENDIF
274          ENDIF
275   170 CONTINUE
276 *
277 *               Write next start of event data structure
278       IUHEAD(1)=IDVERS
279       IUHEAD(2)=NWOUT-IOFW
280       NUH=2
281       IF(IOPTI.NE.0) THEN
282          CALL FZOUT(LUN,IXCONS,JRUNG,1,'L',2,NUH,IUHEAD)
283       ELSEIF(IOPTT+IOPTK.NE.0) THEN
284          CALL FZOUT(LUN,IXDIV,JHEAD,1,'L',2,NUH,IUHEAD)
285       ENDIF
286       IF(IQUEST(1).EQ.0) THEN
287          IVERSI(NPOS)=IDVERS
288          IRESUL(NPOS)=1
289       ELSE
290          WRITE(CHMAIL,10500) KNAMES(LINK(NPOS))
291       ENDIF
292 *
293       DO 180 IK=1,NLINK
294 *
295 *              Write selected data structures
296          NKEY=LINK(IK)
297          IF(NKEY.GT.0) THEN
298             IF(NKEY.EQ.9) THEN
299                GOTO 180
300             ELSEIF(NKEY.EQ.3) THEN
301                GOTO 180
302             ELSEIF(NKEY.EQ.1) THEN
303                CALL GRLEAS(JDIGI)
304             ELSEIF(NKEY.EQ.4) THEN
305                CALL GRLEAS(JHITS)
306             ENDIF
307             IDIV=LDIV(IXD(NKEY))
308             JKEY=JTRAN(NKEY)
309             IF(NKEY.LE.20)THEN
310                CALL FZOUT(LUN,IDIV,JNAMES(NKEY),0,'L',2,1,JKEY)
311             ELSE
312                NKL=NKEY-20
313                CALL FZOUT(LUN,IDIV,ISLINK(NKL),0,'L',2,1,JKEY)
314             ENDIF
315             IF(IQUEST(1).EQ.0) THEN
316                IVERSI(IK)=IDVERS
317                IRESUL(IK)=1
318             ELSE
319                WRITE(CHMAIL,10500) KNAMES(NKEY)
320             ENDIF
321          ENDIF
322   180 CONTINUE
323 *
324       NOUT=0
325       DO 190 I=1,NLINK
326          IF(IRESUL(I).EQ.1) THEN
327             WRITE(CHMAIL,10600) KNAMES(ABS(LINK(I))),IVERSI(I)
328             IF(IOPTQ.EQ.0) CALL GMAIL(0,0)
329             NOUT=NOUT+1
330          ELSE
331             WRITE(CHMAIL,10700) KNAMES(ABS(LINK(I)))
332             IF(IOPTQ.EQ.0) CALL GMAIL(0,0)
333          ENDIF
334   190 CONTINUE
335 *
336       IF(NOUT.LE.0) THEN
337          WRITE(CHMAIL,10800)
338          IF(IOPTQ.EQ.0) CALL GMAIL(0,0)
339          IER=-1
340       ELSEIF(NOUT.LT.NLINK) THEN
341          IER=NOUT
342       ENDIF
343 *
344 10000 FORMAT(' *** GFOUT *** Key ',A4,' ignored for initialization')
345 10100 FORMAT(' *** GFOUT *** Key ',A4,' ignored for kinematics')
346 10200 FORMAT(' *** GFOUT *** Key ',A4,' ignored for trigger')
347 10300 FORMAT(' *** GFOUT *** Unknown key ',A4)
348 10400 FORMAT(' *** GFOUT *** No valid key given')
349 10500 FORMAT(' *** GFOUT *** Problems writing data structure ',A4)
350 10600 FORMAT(' *** GFOUT *** Data structure ',A4,' version ',I10,
351      +       ' successfully written out')
352 10700 FORMAT(' *** GFOUT *** Data structure ',A4,' not found')
353 10800 FORMAT(' *** GFOUT *** Nothing written out !')
354   999 END