/[PAMELA software]/yoda/techmodel/forroutines/calorimeter/calunpack.for
ViewVC logotype

Annotation of /yoda/techmodel/forroutines/calorimeter/calunpack.for

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5.0 - (hide annotations) (download)
Mon Aug 29 09:46:13 2005 UTC (19 years, 3 months ago) by kusanagi
Branch: MAIN
CVS Tags: YODA5_0/00, YODA5_0/01, YODA5_0/02
Changes since 4.4: +0 -0 lines
Starting form this version:
1) includes are defined with relative (not absolute) path respect to the YODA aplication
2) RegistryEvent class is foreseen to contain post-unpack data.

1 kusanagi 1.8 C
2 kusanagi 2.2 C Written by Emiliano Mocchiutti and Mirko Boezio
3 kusanagi 1.8 C
4 kusanagi 2.10 C * Version: 3.4.06 *
5 kusanagi 1.9 C
6 kusanagi 2.2 C Changelog:
7     C
8 kusanagi 2.10 C 3.4.05 - 3.4.06: (2005-01-12) section order wrong in CLEARSEC, fixed.
9     C
10 kusanagi 2.9 C 3.4.04 - 3.4.05: (2005-01-05) XE is section y odd not even, fixed.
11     C
12 kusanagi 2.8 C 3.4.03 - 3.4.04: (2004-12-21) bug in recognising decoding errors, fixed.
13     C
14 kusanagi 2.7 C 3.4.02 - 3.4.03: (2004-12-17) forget to clear esci/stwerr and vector vect
15     C plus problems with lleng (truncated vect!). Fixed the
16     C clearing, workaround for lleng (to be further investigated)
17     C
18 kusanagi 2.6 C 3.4.01 - 3.4.02: (2004-12-10) cleanup of the code and changed sections order.
19     C
20 kusanagi 2.5 C 3.4.00 - 3.4.01: (2004-11-26) CA50 comes after Strips Hit, fixed.
21     C
22     C 3.3.03 - 3.4.00: (2004-11-08) changed the DSP program hence changed calunpack
23     C to better find the calorimeter sections.
24     C
25     C 3.3.02 - 3.3.03: (2004-11-08) changes in the commons (one more common for
26     C calpulse and from calstripshit to calstriphit).
27     C
28     C 3.3.01 - 3.3.02: (2004-10-19) italian name of subroutines translated to
29     C english. Forgot to clear vector in case of CRC errors,
30     C fixed. stwerr is integer not real! fixed
31     C
32 kusanagi 2.4 C 3.3.00 - 3.3.01: (2004-10-18) forgot to clear stwerr if no sections are found
33     C fixed.
34     C
35 kusanagi 2.2 C 3.2.00 - 3.3.00: (2004-10-15) enanched search of sections in case of one or
36     C more missing sections.
37     C Switched to c function "fillin" to create calorimeter words
38     C instead of fortran function "riempi": great improvement in
39     C time processing!!
40     C
41     C 3.1.00 - 3.2.00: (2004-10-13) forget to clean some variables, fixed.
42     C Reprocess event in the case we have CRC errors and a high
43     C number of error trying to understand the kind of event
44     C we are processing (raw, compress, full mode) in order to
45 kusanagi 2.4 C distinguish better the four section.The reprocessing happens
46 kusanagi 2.2 C on about the 30% of events with CRC errors (in the case of
47     C file 040827_005 the reprocessing is done on about 2% of all
48     C the events).
49     C
50     C 3.0.00 - 3.1.00: (2004-10-12) cleanup and speedup of the code, less loops
51     C same strength in finding the calorimeter sections.
52     C
53     C 2.18.4 - 3.0.00: (2004-10-07) major changes in the procedure to find the
54     C calorimeter sections and enhanced search in the case of
55     c CRC errors (to fix a bug which made the misunderstanding
56     C some kind of CRC errors with missing sections).
57     C Clean up unused variables, speeded up some loops.
58     C Zero length input vector error added.
59     C Enhanced search of the first section recorded since the
60     C starting point is very important to correctly find and
61     C interpret all the other sections.
62     C If section length is absurd and the CRC header bit = 0
63     C then search again for that section (needed to make a
64     C better search of section when in presence of CRC errors)
65     C Search all the sections and if you reach the end of vector
66     C (EOV) continue searching if you haven't find all the four
67     C section (and go out without looping if no section is
68     C present).
69 kusanagi 2.1 C
70     C 2.18.3 - 2.18.4: consider a bad thing if you find a section in the wrong
71     C position of the vector and try again to
72     C find the real data (if they exist).
73     C
74     C 2.18.2 - 2.18.3: vectors belonging to common must be cleared if the calo
75     C isn't found. Fixed.
76 kusanagi 1.8 C
77 kusanagi 2.1 C 2.18.1 - 2.18.2: fixed unclearing error codes if the program doesn't find
78     C the calorimeter where it should be but shifted somewhere
79 kusanagi 2.2 C else forgotten to clear st2c variable: fixed
80 kusanagi 2.1 C exit error code wrong in some cases: fixed
81 kusanagi 2.2 C self trigger data not saved: fixed.
82 kusanagi 2.1 C
83     C 2.18.0 - 2.18.1: small changes in the common varie to fix a memory leak;
84 kusanagi 2.2 C fixed an error in reporting error codes (stwerr,pwerror).
85 kusanagi 2.1 C
86 kusanagi 2.2 C 2.17.0 - 2.18.0: corrected bug which made unable the program to find CRC
87     C errors in the last section of the calorimeter;
88     C added a "debugging" option to dump to standard output
89     C the whole packet in hexadecimal format and other
90     C useful informations. To activate it the dump variable
91     C in the common varie must be passed with the value
92     C of iev you want to check. Do nothing if you don't want
93     C any output.
94 kusanagi 1.9 C
95 kusanagi 1.3 C------------------------------------------------
96 kusanagi 1.7 SUBROUTINE CALUNPACK(vecta,lung,me)
97 kusanagi 1.3 C------------------------------------------------
98    
99     IMPLICIT NONE
100     C
101 kusanagi 2.2 C PARAMETERS DEFINITION
102     C
103     C START = WHERE TO START TO LOOK FOR THE CALORIMETER, IN WORDS
104     C 1STSEC = MAXIMUM POSITION, IN BYTES, WHERE WE SUPPOSE TO FIND THE
105     C HEADER OF THE FIRST SECTION
106 kusanagi 1.3 C
107 kusanagi 2.2 INTEGER START, SEC1ST
108 kusanagi 1.3 INTEGER NPLA, NCHA, LENSEV
109 kusanagi 2.2 INTEGER*2 ival
110     C
111     PARAMETER (START=50,SEC1ST=1200)
112 kusanagi 1.3 PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
113 kusanagi 2.2 PARAMETER (ival='FFFF'x)
114 kusanagi 1.3 C
115 kusanagi 2.2 C Normal variables definition
116 kusanagi 1.3 C
117 kusanagi 2.2 integer lung, SOGLIA0, SEC2ND
118 kusanagi 1.7 INTEGER*1 VECTA(lung)
119 kusanagi 1.9 INTEGER*2 vect(60000), test
120 kusanagi 1.6 integer*2 check, crc, e2(4)
121 kusanagi 2.2 INTEGER*2 length, length2
122     integer me, m, dumpo, finoa
123     INTEGER merror(4), headcor, ichc, coco
124 kusanagi 2.6 INTEGER i, j, iev, min, st2c, bit, bi, lleng
125 kusanagi 2.2 INTEGER ic, k,l, ke, ic0, icsave, chi
126     INTEGER hcchi(1000), hcic(1000),hcco
127     INTEGER contr, isfull, israw, iscomp
128     INTEGER inf, sup, em, icb
129 kusanagi 2.6 INTEGER XO, YO, XE, YE, icold
130 kusanagi 2.2 integer st1b, st2b, lunga, pari
131     integer stwerr(4),yescbra, chis, esci, icprima
132     integer seemcomp, seemfull, cberaw, yesisco, yesisfu,yesisra
133 kusanagi 2.5 integer ca50, ca50a, ca50b
134 kusanagi 2.2 C
135 kusanagi 1.3 real dedx1(11,96),dedx2(11,96),dedx3(11,96),dedx4(11,96)
136     real dedx1c(11,96),dedx2c(11,96),dedx3c(11,96),dedx4c(11,96)
137     real base1(11,6),base2(11,6),base3(11,6),base4(11,6)
138 kusanagi 2.2 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
139 kusanagi 1.3 real auto(7)
140 kusanagi 2.5 real calselftrig(4,7), calIItrig(4), calstriphit(4),
141 kusanagi 1.3 & calDSPtaberr(4), calevnum(4)
142 kusanagi 2.2 real perror(4)
143     C
144 kusanagi 2.5 DATA YE/246/ ! CODE_EV_R YE = 111 10110
145 kusanagi 1.3 DATA YO/237/ ! CODE_EV_R YO = 111 01101
146     DATA XE/234/ ! CODE_EV_R XE = 111 01010
147 kusanagi 2.5 DATA XO/241/ ! CODE_EV_R XO = 111 10001
148 kusanagi 2.2 C
149 kusanagi 2.6 COMMON / evento / iev, stwerr, perror,
150 kusanagi 1.3 & dexy,dexyc,base,
151     & calselftrig,calIItrig,
152 kusanagi 2.5 & calstriphit,calDSPtaberr,calevnum
153 kusanagi 1.3 save / evento /
154 kusanagi 2.2 C
155 kusanagi 2.8 COMMON / VARIE / dumpo, CONTR, merror
156 kusanagi 2.2 SAVE / VARIE /
157 kusanagi 1.3 C
158     C Begin !
159     C
160 kusanagi 2.2 SOGLIA0 = 70
161     C
162     C input length must be > 0, if not go out with error code 142
163     C
164 kusanagi 2.5 if (lung.le.0) then
165 kusanagi 2.2 if (dumpo.eq.iev) print *,'lung = ',lung
166     do i=1,4
167     merror(i)=142
168     enddo
169     goto 999
170     endif
171     C
172     C no debug informations
173     C
174 kusanagi 2.1 if (dumpo.eq.0) dumpo=-1
175 kusanagi 2.2 C
176     C DEBUG: PRINT OUT THE INPUT VECTOR
177     C
178 kusanagi 2.1 if (iev.eq.dumpo) then
179 kusanagi 1.9 do l=1,lung
180     write(*,17)l,vecta(l)
181     enddo
182     endif
183 kusanagi 2.2 C
184     C DETERMINE LENGTH IN WORDS FROM LENGTH IN BYTES
185     C
186 kusanagi 1.7 IF (MOD(LUNG,2).EQ.0) THEN
187     lunga = lung / 2
188     pari = 1
189     else
190     lunga = int(lung/2) + 1
191     endif
192 kusanagi 2.2 SEC2ND = LUNGA
193     C
194     C IS LENGTH IS TOO LONG?
195     C
196 kusanagi 2.1 if (lunga.gt.60000.and.dumpo.gt.0) then
197 kusanagi 1.9 print *,'Calorimeter WARNING: more than 60000 words!'
198     lunga = 60000
199 kusanagi 1.6 endif
200 kusanagi 2.2 C
201     C PRE-CLEAR VARIABLES
202     C
203     yesisco = 0
204     yesisfu = 0
205     yesisra = 0
206     yescbra = 0
207     C
208     1 CONTINUE
209 kusanagi 1.5 c
210 kusanagi 2.2 C CLEAR VARIABLES
211     C
212     if (iev.lt.0.or.iev.gt.90000000) iev = 0
213     esci = 0
214     chi = 0
215     chis = 0
216     min = 0
217     lleng = 0
218     m = 0
219     pari = 0
220     icb = 0
221     em = 0
222     coco = 0
223     me = 1
224     contr = 1
225     ic = 1
226     icsave = 0
227     C
228 kusanagi 2.5 call clearall
229 kusanagi 1.6 call azero(dedx1,11*96)
230     call azero(dedx2,11*96)
231     call azero(dedx3,11*96)
232     call azero(dedx4,11*96)
233     call azero(dedx1c,11*96)
234     call azero(dedx2c,11*96)
235     call azero(dedx3c,11*96)
236     call azero(dedx4c,11*96)
237     call azero(base1,11*6)
238     call azero(base2,11*6)
239     call azero(base3,11*6)
240     call azero(base4,11*6)
241     C
242 kusanagi 1.5 do l = 1,4
243 kusanagi 2.1 e2(l) = 0
244 kusanagi 1.8 perror(l) = 0.
245     stwerr(l) = 0
246 kusanagi 1.5 merror(l) = 0
247     enddo
248 kusanagi 2.2 C
249     C DETERMINE WHERE TO START TO FIND THE CALORIMETER IN THE INBUT BUFFER
250     C
251     length2 = start
252 kusanagi 1.3 c
253     20 continue
254 kusanagi 2.2 C
255 kusanagi 1.5 if (length2.ge.-2) then
256     ic = ic + (2 * (length2 + 2))
257     else
258 kusanagi 2.1 if (dumpo.gt.0)
259 kusanagi 2.2 & print *,'Calorimeter WARNING: length errors ',ic,length2
260 kusanagi 1.5 endif
261 kusanagi 2.2 C
262     headcor = 0
263     ichc = ic
264     icprima = ic
265     hcco = 0
266     do i=1,1000
267     hcchi(i) = 0
268     hcic(i) = 0
269     enddo
270 kusanagi 1.5 c
271     32 continue
272 kusanagi 2.2 C
273 kusanagi 1.3 ke = 0
274 kusanagi 2.2 chis = chi
275 kusanagi 2.1 icold = ic
276 kusanagi 2.7 DO i = 1, 60000
277     vect(i) = 0
278     enddo
279 kusanagi 1.3 do while (ke.eq.0)
280     C
281 kusanagi 2.2 C if (iev.eq.dumpo) print *,'parto da ',ic,contr
282     C
283 kusanagi 1.3 C Check consistency of header.
284     C it is composed by CODE+D# (8 bits) and by SATUS WORD (8 bits)
285     c so we must split vect into the two components:
286     C
287 kusanagi 1.5 st1b = 0
288     st2b = 0
289 kusanagi 2.2 C
290     C A CALORIMETER SECTION IS MADE OF AT LEAST 4 BYTES
291     C IF WE HAVE NO ROOM FOR A SECTION GO OUT
292     C
293     if ((ic+4).gt.lung.or.esci.eq.1) then
294     if (headcor.eq.1.and.contr.lt.5) then
295     headcor=-1
296     ic=ichc
297     goto 32
298     else
299     if (headcor.eq.0.or.headcor.eq.2) then
300     chi = chi + 8 * (5 - contr)
301     endif
302     merror(contr) = 129
303 kusanagi 2.7 stwerr(contr) = 0
304 kusanagi 2.6 if (iev.eq.dumpo) print *,'put to zero here ',headcor
305 kusanagi 2.2 if (esci.eq.0) then
306     ic = icsave
307     else
308     ic = icprima
309     endif
310     if (headcor.eq.2) then
311     chi = chis
312     endif
313     esci = 0
314     headcor = 0
315     hcco = 0
316     ichc = 0
317     do i=1,1000
318     hcchi(i) = 0
319     hcic(i) = 0
320     enddo
321     length2 = -2
322     lleng = 0
323     length = 0
324     goto 150
325     endif
326 kusanagi 1.7 endif
327 kusanagi 2.2 C
328     C ST1B IS "CODE", ST2B IS "D#"
329     C
330 kusanagi 1.5 do bit = 0, 7
331     bi = ibits(vecta(ic),bit,1)
332     if (bi.eq.1) st1b = ibset(st1b,bit)
333     bi = ibits(vecta(ic+1),bit,1)
334     if (bi.eq.1) st2b = ibset(st2b,bit)
335     enddo
336 kusanagi 1.6 c
337 kusanagi 2.2 C IC+2 AND IC+3 CONTAINS THE LENGTH OF THE CALORIMETER SECTION
338 kusanagi 1.6 c
339 kusanagi 1.5 length2 = 0
340     do bit=0, 7
341     bi = ibits(vecta(ic+3),bit,1)
342     if (bi.eq.1) length2 = ibset(length2,bit)
343     bi = ibits(vecta(ic+2),bit,1)
344     if (bi.eq.1) length2 = ibset(length2,bit+8)
345 kusanagi 2.5 enddo
346     C
347     C calorimeter signature in DSP mode (CA50 CA50):
348     C
349     ca50 = 0
350     if (ic+24.lt.lung) then
351     ca50a = 0
352     do bit=0, 7
353     bi = ibits(vecta(ic+23),bit,1)
354     if (bi.eq.1) ca50a = ibset(ca50a,bit)
355     bi = ibits(vecta(ic+22),bit,1)
356     if (bi.eq.1) ca50a = ibset(ca50a,bit+8)
357     enddo
358     ca50b = 0
359     do bit=0, 7
360     bi = ibits(vecta(ic+25),bit,1)
361     if (bi.eq.1) ca50b = ibset(ca50b,bit)
362     bi = ibits(vecta(ic+24),bit,1)
363     if (bi.eq.1) ca50b = ibset(ca50b,bit+8)
364     enddo
365     if (ca50a.eq.ca50b.and.ca50a.eq.51792) ca50 = 1
366     endif
367    
368 kusanagi 2.2 C
369 kusanagi 1.3 c the crc should be at vect(length) with
370 kusanagi 2.2 C
371 kusanagi 1.5 length = length2 + 1
372 kusanagi 1.3 C
373 kusanagi 2.2 c some checks to be sure we have found the calorimeter data:
374 kusanagi 1.3 c status word is always less then 129
375     c
376 kusanagi 1.5 if (st2b.gt.128) then
377     length = 0
378 kusanagi 2.2 length2 = 0
379 kusanagi 1.5 goto 100
380     endif
381 kusanagi 1.3 c
382 kusanagi 2.2 c length of the packet IN WORDS must be less then HALF OF THE
383     C LENGTH IN BYTES if noT THERE ARE SOME errors
384 kusanagi 1.3 c
385 kusanagi 2.2 bi = ibits(st2b,0,1)
386     if (length2.gt.lunga.OR.LENGTH2.LE.0) then
387     if (headcor.eq.2) then
388     chi = chi + 4
389     endif
390 kusanagi 1.5 length = 0
391 kusanagi 2.2 length2 = 0
392 kusanagi 1.5 goto 100
393     endif
394     c
395 kusanagi 1.3 e2(contr) = 0
396     C
397 kusanagi 2.2 if (CONTR.eq.1) then
398 kusanagi 1.3 c
399     c is it the first section?
400     c
401 kusanagi 2.5 if (st1b.eq.XE.and.(ca50.eq.1.or.length2.eq.1064)) then
402 kusanagi 1.3 c if so go out of this loop and go on recording data
403     ke = 1
404 kusanagi 2.2 icsave = ic
405     m = ic
406 kusanagi 2.7 if (iev.eq.dumpo) then
407     print *,'1m,lunga,lleng,lung,pari',m,lunga,lleng,lung,
408     & pari
409     endif
410 kusanagi 2.2 call fillin(m,lunga,lleng,lung,pari,vect,vecta)
411     C
412 kusanagi 1.5 icb = 1
413 kusanagi 2.2 E2(contr) = vect(icb)
414 kusanagi 2.7 if (iev.eq.dumpo) then
415     print *,'headcor ',headcor
416     write(*,22)vect(icb)
417     print *,'1m,lunga,lleng,lung,pari',m,lunga,lleng,lung,
418     & pari
419     endif
420 kusanagi 2.2 if (headcor.eq.2) then
421     if (coco.ne.1) then
422     coco = 1
423     else
424     coco = -1
425     endif
426     if (st2b.ne.0) then
427 kusanagi 2.5 call counter(e2(contr),chi)
428 kusanagi 2.2 endif
429 kusanagi 1.3 endif
430 kusanagi 2.2 goto 100
431 kusanagi 1.3 endif
432     ENDIF
433     C
434     c the same for the second section, ...
435     c
436     if (CONTR.eq.2) then
437 kusanagi 2.5 if (st1b.eq.XO.and.(ca50.eq.1.or.length2.eq.1064)) then
438 kusanagi 2.2 ke = 2
439     icsave = ic
440 kusanagi 1.5 m = ic
441 kusanagi 2.7 if (iev.eq.dumpo) then
442     print *,'2m,lunga,lleng,lung,pari',m,lunga,lleng,lung,
443     & pari
444     endif
445 kusanagi 2.2 call fillin(m,lunga,lleng,lung,pari,vect,vecta)
446 kusanagi 1.5 icb = 1
447 kusanagi 2.2 E2(contr) = vect(icb)
448 kusanagi 2.7 if (iev.eq.dumpo) then
449     print *,'headcor ',headcor
450     write(*,22)vect(icb)
451     print *,'2m,lunga,lleng,lung,pari',m,lunga,lleng,lung,
452     & pari
453     endif
454 kusanagi 2.2 if (headcor.eq.2) then
455     if (coco.ne.2) then
456     coco = 2
457     else
458     coco = -1
459     endif
460     if ((ic-icold).ne.0) chi=chi+abs(ic-icold)
461     if (st2b.ne.0) then
462 kusanagi 2.5 call counter(e2(contr),chi)
463 kusanagi 1.3 endif
464     endif
465 kusanagi 2.2 goto 100
466 kusanagi 1.3 endif
467     ENDIF
468     c
469     C ... for the third,...
470     c
471     if (CONTR.eq.3) then
472 kusanagi 2.5 if (st1b.eq.YE.and.(ca50.eq.1.or.length2.eq.1064)) then
473 kusanagi 2.2 ke = 3
474     icsave = ic
475     m = ic
476     if (iev.eq.dumpo) then
477 kusanagi 2.7 print *,'3m,lunga,lleng,lung,pari',m,lunga,lleng,lung,
478 kusanagi 2.2 & pari
479 kusanagi 1.3 endif
480 kusanagi 2.2 call fillin(m,lunga,lleng,lung,pari,vect,vecta)
481 kusanagi 1.5 icb = 1
482 kusanagi 2.2 E2(contr) = vect(icb)
483     if (iev.eq.dumpo) then
484     print *,'headcor ',headcor
485     write(*,22)vect(icb)
486 kusanagi 2.7 print *,'3m,lunga,lleng,lung,pari',m,lunga,lleng,lung,
487 kusanagi 2.2 & pari
488 kusanagi 1.3 endif
489 kusanagi 2.2 if (headcor.eq.2) then
490     if (coco.eq.3) then
491     coco = 3
492     else
493     coco = -1
494     endif
495     if (ic-icold.ne.0) chi = chi + abs(ic-icold)
496     if (st2b.ne.0) then
497 kusanagi 2.5 call counter(e2(contr),chi)
498 kusanagi 1.3 endif
499     endif
500 kusanagi 2.2 goto 100
501 kusanagi 1.3 endif
502     ENDIF
503     C
504     c ...and for the last section.
505     c
506     if (CONTR.eq.4) then
507 kusanagi 2.5 if (st1b.eq.YO.and.(ca50.eq.1.or.length2.eq.1064)) then
508 kusanagi 2.2 ke = 4
509     icsave = ic
510 kusanagi 1.5 m = ic
511 kusanagi 2.2 call fillin(m,lunga,lleng,lung,pari,vect,vecta)
512 kusanagi 1.5 icb = 1
513 kusanagi 2.2 E2(contr) = vect(icb)
514     if (headcor.eq.2) then
515     if (coco.eq.4) then
516     coco = 4
517     else
518     coco = -1
519     endif
520     if ((ic-icold).ne.0) chi = chi + abs(ic-icold)
521     if (st2b.ne.0) then
522 kusanagi 2.5 call counter(e2(contr),chi)
523 kusanagi 2.2 endif
524 kusanagi 1.3 endif
525 kusanagi 1.5 goto 100
526 kusanagi 1.3 endif
527     endif
528 kusanagi 2.2 C
529     if (contr.gt.4) then
530 kusanagi 2.6 if (iev.eq.dumpo) print *,'go out here'
531 kusanagi 2.2 headcor = 0
532     hcco = 0
533     ichc = 0
534     do i=1,1000
535     hcchi(i) = 0
536     hcic(i) = 0
537     enddo
538     goto 200
539     endif
540 kusanagi 1.3 C
541     100 CONTINUE
542     c
543     c increment vector of one searching for the next section
544     c
545     ic = ic + 1
546     c
547     enddo
548     C
549     c format not used
550     c
551 kusanagi 1.7 10 FORMAT(2X,'Error for view:',2X,I1,2X,'Status word:',2X,Z4)
552     11 FORMAT(2X,'View or command not recognized for view:',2X,I1,2X,
553     & 'Status word:',2X,Z4)
554     12 FORMAT(2X,'Error - did NOT find view:',2X,I1)
555     13 FORMAT(2X,'Error - eof reached, exiting')
556     14 FORMAT(2X,I8,2X,I10)
557     15 FORMAT(2X,I8,2X,Z8)
558 kusanagi 2.5 17 FORMAT(2X,'Element:',2X,I6,2X,' word:',2X,Z8)
559     18 FORMAT(2X,'Element:',2X,I6,2X,' word:',2X,Z2,Z2)
560 kusanagi 1.9 21 FORMAT(2X,'CRC: ',2X,Z8)
561 kusanagi 2.2 22 FORMAT(2X,'vect(icb): ',2X,Z8)
562 kusanagi 1.9 C
563 kusanagi 1.3 c go on recording data
564 kusanagi 1.7 ic = ic - 1
565 kusanagi 2.2 c
566 kusanagi 1.7 c
567     K = CONTR
568     ic0 = icb
569     icb = icb + 1
570     length = vect(icb) + 2
571     length2 = vect(icb)
572 kusanagi 1.8 lleng = (length*2) - 1
573 kusanagi 1.3 C
574 kusanagi 2.2 C Check consistency of CRCs.
575     C
576     C
577     C IF THE STATUS WORD HAS THE CRC BIT ON AND WE ARE NOT IN THE
578     C HEADCOR CASE 0 (WE WERE BELIEVING THE SECTION FOUND WAS FINE)
579     C
580     if ((ibits(e2(contr),0,1).ne.0.or.
581     & (ibits(e2(contr),3,1).eq.1.and.length2.ne.1064))
582     & .and.headcor.EQ.0) then
583     headcor = 1
584     ichc = ic - 1
585     if (iev.eq.dumpo) print *,'crc st word wrong',ic,ichc,headcor
586     endif
587     C
588     C HEADOCR = 1 MEANS SEARCH AGAIN FOR THAT SECTION
589 kusanagi 1.3 C
590 kusanagi 2.2 if (headcor.eq.1) then
591     hcco = hcco + 1
592     if (st2b.ne.0) then
593 kusanagi 2.5 call counter(e2(contr),hcchi(hcco))
594 kusanagi 2.2 endif
595     C
596     if (contr.gt.1.or.yesisco.ne.0.or.yesisfu.ne.0
597     & .or.yesisra.ne.0.or.yescbra.ne.0) then
598     iscomp = 0
599     isfull = 0
600     israw = 0
601     if (yesisco.ne.0.or.yesisfu.ne.0
602     & .or.yesisra.ne.0.or.yescbra.ne.0) then
603     if (yesisra.ne.0.or.yescbra.ne.0) israw = 2
604     if (yesisco.ne.0) iscomp = 2
605     if (yesisfu.ne.0) isfull = 2
606     else
607     i = 1
608     do while(iscomp.eq.0.and.isfull.eq.0.and.israw.eq.0.and.
609     & i.lt.(contr-1))
610     if (ibits(stwerr(i),16,1).eq.1) iscomp = iscomp + 1
611     if (ibits(stwerr(i),17,1).eq.1) isfull = isfull + 1
612     if (ibits(e2(i),3,1).eq.1.and.merror(i).eq.0)
613     & israw = israw + 1
614     i = i + 1
615     enddo
616     endif
617     c
618     c how does this section look like? (note that in case of crc errors
619     c this test has no value...)
620     c
621 kusanagi 2.5 test = vect(icb+12)
622 kusanagi 2.2 seemcomp = 0
623     seemfull = 0
624     if (test.eq.ival) then
625     seemcomp = 1
626     elseif (test.eq.0) then
627     seemfull = 1
628     endif
629     c
630     c if a previous good section was raw and this header we are analyzing
631     c is not raw something strange is happening, add a weight.
632     c
633     if ((israw.ne.0.and.ibits(e2(contr),3,1).ne.1)
634     & .or.(israw.ne.0.and.length2.ne.1064)) then
635     hcco = hcco - 1
636     length=0
637     length2=0
638     lleng=0
639     ic = ic + 1
640     if (iev.eq.dumpo)
641     & print *,'not raw, search again ',ic,ichc,headcor
642     goto 32
643     endif
644     c
645     c the same with compress and full mode
646     c
647     if ((iscomp.ne.0.or.isfull.ne.0)
648     & .and.ibits(e2(contr),3,1).eq.1) then
649     hcco = hcco - 1
650     length=0
651     length2=0
652     lleng=0
653     ic = ic + 1
654     if (iev.eq.dumpo)
655     & print *,'raw in full or compress mode, search again ',ic,ichc,
656     & headcor
657     goto 32
658     endif
659    
660     if (iscomp.ne.0.and.(ibits(e2(contr),3,1).eq.1.or.
661     & seemcomp.eq.0)) hcchi(hcco) = hcchi(hcco) + 2
662     if (isfull.ne.0.and.(ibits(e2(contr),3,1).eq.1.or.
663     & seemfull.eq.0)) hcchi(hcco) = hcchi(hcco) + 2
664     endif
665     C
666     if (ibits(e2(contr),3,1).eq.1.and.length2.eq.1064) then
667     hcchi(hcco) = hcchi(hcco) - 2
668     elseif ((ibits(e2(contr),3,1).eq.1.or.israw.ne.0)
669     & .and.length2.ne.1064) then
670     hcco = hcco - 1
671     length=0
672     length2=0
673     lleng=0
674     ic = ic + 1
675     if (iev.eq.dumpo)
676     & print *,'raw bit not raw length, search again ',ic,ichc,headcor
677     goto 32
678     endif
679     C
680     hcic(hcco) = ic
681     ic = ic + 1
682     length=0
683     length2=0
684     lleng=0
685     if (iev.eq.dumpo) print *,'search again ',ic,ichc,headcor
686     goto 32
687     endif
688     C
689     C HEADCOR = - 1 MEANS STOP SEARCHING FOR THAT SECTION, SELECT
690     C THE CASE WITH LESS ERRORS, FOUND THAT SECTION AND GIVE
691     C HEADCOR = 2 (I.E. GO OUT OF THE LOOP)
692     C
693     if (headcor.eq.-1) then
694 kusanagi 2.6 if (iev.eq.dumpo) print *,'enter -1, ',hcco,ke
695 kusanagi 2.2 headcor = 2
696     if (ke.le.2.and.hcco.ge.1) then
697     finoa = 0
698     do i = 1, hcco
699     if (ke.eq.1.and.hcic(i).lt.SEC1ST) finoa = i
700     if (ke.eq.2.and.hcic(i).lt.SEC2ND) finoa = i
701     enddo
702     if (finoa.eq.0) then
703     esci = 1
704     if (iev.eq.dumpo)
705     & print *,'finoa=0! no possible solutions '
706     else
707     if (iev.eq.dumpo) print *,'ke = ',ke,' and hcco>1 ',finoa
708     call minerr(ic,hcic,hcchi,min,finoa)
709     endif
710     else
711     if (hcco.eq.0) then
712     esci = 1
713     if (iev.eq.dumpo)
714     & print *,'hcco=0! no possible solutions'
715     else
716     call minerr(ic,hcic,hcchi,min,hcco)
717     endif
718     endif
719     e2(contr) = 0
720     if (iev.eq.dumpo) then
721     print *,'stop searching'
722     print *,'ic,hcic(min),min,... ',ic,hcic(min),min,
723     & hcchi(min),hcco,coco
724     do i=1,hcco
725     print *,'i, hcchi ',i,hcchi(i)
726     enddo
727     endif
728     c
729     length=0
730     length2=0
731     lleng=0
732 kusanagi 2.7 esci = 0
733     MERROR(contr) = 0
734 kusanagi 2.2 goto 32
735     endif
736     C
737     C determine the type of data if not raw (compress or full)
738     C
739     if (headcor.eq.0.or.headcor.eq.2
740     & .and.ibits(e2(contr),3,1).ne.1) then
741 kusanagi 2.5 test = vect(icb+12)
742 kusanagi 2.2 seemcomp = 0
743     seemfull = 0
744     if (test.eq.ival) then
745 kusanagi 2.5 C
746 kusanagi 2.2 C compress mode
747 kusanagi 2.5 C
748 kusanagi 2.2 stwerr(contr) = ibset(stwerr(contr),16)
749     elseif (test.eq.0) then
750     C
751 kusanagi 2.5 C full mode
752     C
753 kusanagi 2.2 stwerr(contr) = ibset(stwerr(contr),17)
754     endif
755     endif
756     C
757     hcco = 0
758     ichc = 0
759 kusanagi 2.1 check = 0
760 kusanagi 2.2 do i=1,1000
761     hcchi(i) = 0
762     hcic(i) = 0
763     enddo
764 kusanagi 1.7 inf = ic0
765     sup = length - 1
766     do i = inf,sup
767     check=crc(check,vect(i))
768     enddo
769 kusanagi 2.2 C
770 kusanagi 2.7 if (iev.eq.dumpo) then
771     write(*,21)vect(length)
772     print *,' CRC position ',length
773     write(*,21)check
774     endif
775 kusanagi 2.2 C
776 kusanagi 1.7 if (check.ne.vect(length)) then
777     merror(contr) = 132
778 kusanagi 2.2 chi = chi + 4
779 kusanagi 1.7 lleng = 0
780 kusanagi 2.2 length2 = 0
781     length = 0
782 kusanagi 2.5 C
783     C clear vectors of that section in the common
784     C
785     call clearsec
786     C
787 kusanagi 2.2 if (ke.eq.1.and.headcor.ne.2) then
788     ic = 10
789     elseif (headcor.eq.2) then
790     contr = contr + 1
791 kusanagi 1.8 endif
792 kusanagi 2.2 headcor = 1
793     ichc = ic - 1
794     if (iev.eq.dumpo)
795 kusanagi 2.6 & print *,'crc is wrong ',ic,
796     & ' search section ',contr,' coco = ',coco
797 kusanagi 2.2 goto 32
798     else
799     chi = chi - 4
800     if (chi.lt.0) chi = 0
801 kusanagi 1.7 endif
802 kusanagi 2.2 C
803     headcor = 0
804 kusanagi 1.3 C
805 kusanagi 1.8 19 CONTINUE
806 kusanagi 2.2 C
807     C Process data.
808     C
809 kusanagi 2.5 call clearsec
810 kusanagi 2.2 do i = 1, 7
811     icb = icb + 1
812     auto(i) = vect(icb)
813     enddo
814     C
815     st2c = 0
816     if (st2b.ne.0) then
817     do bit=0, 6
818     bi = ibits(st2b,bit,1)
819     if (bit.eq.3.and.bi.ne.0) st2c = 8
820 kusanagi 1.3 enddo
821 kusanagi 2.2 endif
822 kusanagi 1.7 C
823 kusanagi 2.2 if (st2c.eq.8) then
824     if (length2.ne.1064) then
825     merror(contr) = 133
826     chi = chi + 4
827     if (iev.eq.dumpo)
828     & print *,'raw lung 4'
829     lleng = 0
830     goto 150
831     else
832 kusanagi 2.5 if (k.eq.1) call CALRAW(vect,icb+1,length-1,dedx1)
833 kusanagi 2.2 if (k.eq.2) call CALRAW(vect,icb+1,length-1,dedx2)
834     if (k.eq.3) call CALRAW(vect,icb+1,length-1,dedx3)
835     if (k.eq.4) call CALRAW(vect,icb+1,length-1,dedx4)
836 kusanagi 1.5 endif
837 kusanagi 2.2 goto 50
838     endif
839 kusanagi 1.7 C
840 kusanagi 2.2 41 FORMAT(2X,I2,2X,'word :',1x,z4)
841 kusanagi 2.5 test = vect(icb+5)
842 kusanagi 2.2 c
843     if (test.eq.ival) then
844     if (length2.gt.1201) then
845     merror(contr) = 134
846     chi = chi + 4
847     if (iev.eq.dumpo)
848     & print *,'compr lung 4'
849     lleng = 0
850     goto 150
851     else
852     icb = icb + 1
853     calIItrig(k) = vect(icb)
854     icb = icb + 1
855 kusanagi 2.5 calstriphit(k) = vect(icb)
856     icb = icb + 1
857     C FIRST CALORIMETER SIGNATURE: CA50
858 kusanagi 2.2 icb = icb + 1
859 kusanagi 2.5 C SECOND CALORIMETER SIGNATURE: CA50
860     icb = icb + 1
861     C test is here!
862 kusanagi 2.2 icb = icb + 1
863     calDSPtaberr(k) = vect(icb)
864     icb = icb + 1
865     calevnum(k) = vect(icb)
866 kusanagi 2.5 if (k.eq.1) call CALCOMPRESS(vect,icb+1,length-1,dedx1c,
867     & base1)
868 kusanagi 2.2 if (k.eq.2) call CALCOMPRESS(vect,icb+1,length-1,dedx2c,
869     & base2)
870     if (k.eq.3) call CALCOMPRESS(vect,icb+1,length-1,dedx3c,
871     & base3)
872     if (k.eq.4) call CALCOMPRESS(vect,icb+1,length-1,dedx4c,
873     & base4)
874 kusanagi 1.5 goto 50
875 kusanagi 1.3 endif
876 kusanagi 2.2 else if (test.eq.0) then
877     if (length2.gt.2257) then
878     merror(contr) = 135
879     chi = chi + 4
880     if (iev.eq.dumpo)
881     & print *,'full lung 4'
882     lleng = 0
883     goto 150
884     else
885     icb = icb + 1
886     calIItrig(k) = vect(icb)
887     icb = icb + 1
888 kusanagi 2.5 calstriphit(k) = vect(icb)
889     icb = icb + 1
890     C FIRST CALORIMETER SIGNATURE: CA50
891 kusanagi 2.2 icb = icb + 1
892 kusanagi 2.5 C SECOND CALORIMETER SIGNATURE: CA50
893     icb = icb + 1
894     C test is here!
895 kusanagi 2.2 icb = icb + 1
896     calDSPtaberr(k) = vect(icb)
897     icb = icb + 1
898     calevnum(k) = vect(icb)
899 kusanagi 2.5 if (k.eq.1) call CALFULL(vect,icb+1,length-1,dedx1,
900     & dedx1c,base1)
901 kusanagi 2.2 if (k.eq.2) call CALFULL(vect,icb+1,length-1,dedx2,
902     & dedx2c,base2)
903     if (k.eq.3) call CALFULL(vect,icb+1,length-1,dedx3,
904     & dedx3c,base3)
905     if (k.eq.4) call CALFULL(vect,icb+1,length-1,dedx4,
906     & dedx4c,base4)
907     goto 50
908 kusanagi 1.3 endif
909 kusanagi 2.2 else
910     merror(contr) = 136
911     chi = chi + 4
912     if (iev.eq.dumpo)
913     & print *,'decoding problems 4'
914     lleng = 0
915     goto 150
916     endif
917 kusanagi 2.1 c
918 kusanagi 2.2 50 continue
919 kusanagi 2.1 c
920 kusanagi 1.7 C
921 kusanagi 2.2 do i = 1,7
922     calselftrig(k,i) = auto(i)
923     enddo
924     C
925     DO I = 1,11
926     DO J = 1,96
927 kusanagi 2.9 DEXY(2,2*I,J) = DEDX2(I,J)
928 kusanagi 2.5 DEXY(1,2*I-1,J) = DEDX4(I,J)
929 kusanagi 2.9 DEXY(2,2*I-1,97-J) = DEDX1(I,J)
930 kusanagi 2.5 DEXY(1,2*I,J) = DEDX3(I,J)
931 kusanagi 2.9 DEXYC(2,2*I,J) = DEDX2C(I,J)
932 kusanagi 2.5 DEXYC(1,2*I-1,J) = DEDX4C(I,J)
933 kusanagi 2.9 DEXYC(2,2*I-1,97-J) = DEDX1C(I,J)
934 kusanagi 2.5 DEXYC(1,2*I,J) = DEDX3C(I,J)
935 kusanagi 1.3 enddo
936 kusanagi 2.2 do j = 1,6
937 kusanagi 2.9 base(2,2*i,j) = base2(i,j)
938 kusanagi 2.5 base(1,2*i-1,j) = base4(i,j)
939 kusanagi 2.9 base(2,2*i-1,7-j) = base1(i,j)
940 kusanagi 2.5 base(1,2*i,j) = base3(i,j)
941 kusanagi 1.3 enddo
942 kusanagi 2.2 enddo
943 kusanagi 1.3 C
944     150 continue
945     C
946     contr = contr + 1
947     C
948     c go on till we have found all the four sections
949     c
950 kusanagi 1.5 if (contr.lt.5) goto 20
951 kusanagi 1.3 c
952 kusanagi 1.8 200 continue
953     C
954 kusanagi 2.2 iscomp = 0
955     isfull = 0
956     israw = 0
957     do i = 1, 4
958     if (ibits(stwerr(i),16,1).eq.1) iscomp = iscomp + 1
959     if (ibits(stwerr(i),17,1).eq.1) isfull = isfull + 1
960     if (ibits(e2(i),3,1).eq.1) israw = israw + 1
961     enddo
962     if (iscomp.ne.0) chi = chi + 8 * (4 - iscomp)
963     if (israw.ne.0) chi = chi + 8 * (4 - israw)
964     if (isfull.ne.0) chi = chi + 8 * (4 - isfull)
965     C
966     C if chi>10 and we have information enough to understand the physic event
967     C was acquired in a certain mode (RAW, FULL or COMPRESS) then reprocess
968     C the event using this information, sometimes we miss a section due to
969     C CRC errors in the previous one but if we know what we are looking for
970     C then it is possible to save this kind of events.
971     C
972     if (chi.gt.5.and.yesisco.eq.0.and.yesisfu.eq.0
973     & .and.yesisra.eq.0.and.yescbra.eq.0) then
974     israw = 0
975     cberaw = 0
976     do i = 1, 4
977     if (ibits(e2(i),3,1).eq.1.and.merror(i).eq.0)
978     & israw = israw + 1
979     if (ibits(e2(i),3,1).eq.1.and.merror(i).eq.132)
980     & cberaw = cberaw + 1
981     enddo
982     yesisco = 0
983     yesisfu = 0
984     yesisra = 0
985     yescbra = 0
986     if (iscomp.ne.0) yesisco = 1
987     if (isfull.ne.0) yesisfu = 1
988     if (israw.ne.0) yesisra = 1
989     if (cberaw.ne.0) yescbra = 1
990     if ((yesisco+yesisfu+yesisra).eq.1.or.
991     & ((yesisco+yesisfu+yesisra).eq.0.and.yescbra.eq.1)) then
992     if (iev.eq.dumpo) then
993     print *,'************************'
994     if (iscomp.ne.0) print *,'is a compress acq.'
995     if (isfull.ne.0) print *,'is a full acq.'
996     if (israw.ne.0) print *,'is a raw acq.'
997     if (israw.eq.0.and.cberaw.ne.0)
998     & print *,'could be a raw acq.'
999     print *,'so, SGARBUF, do it again! ',chi
1000     print *,'************************'
1001 kusanagi 1.8 endif
1002 kusanagi 2.2 SOGLIA0 = SOGLIA0 - ISCOMP - ISFULL - ISRAW
1003     goto 1
1004 kusanagi 1.8 endif
1005 kusanagi 2.2 if ((yesisco+yesisfu+yesisra+yescbra).eq.0) chi = 1000
1006 kusanagi 1.8 endif
1007 kusanagi 2.2 C
1008     if (iev.eq.dumpo)
1009     & print *,'chi <= soglia0 ?',chi,soglia0
1010     if (chi.lt.soglia0) then
1011     me = 0
1012     else
1013     me = 1
1014     do i = 1, 4
1015     merror(i) = 129
1016     e2(i) = 0
1017 kusanagi 2.5 stwerr(i) = 0
1018 kusanagi 2.1 enddo
1019 kusanagi 2.5 call clearall
1020 kusanagi 2.2 goto 999
1021 kusanagi 1.8 endif
1022 kusanagi 1.3 C
1023     C if all section are missing clear vectors and go out
1024     C
1025     if (merror(1).eq.129.and.merror(2).eq.129
1026 kusanagi 2.2 & .and.merror(3).eq.129.and.merror(4).eq.129) then
1027 kusanagi 1.3 do l = 1,4
1028     e2(l) = 0
1029 kusanagi 2.4 stwerr(l) = 0
1030 kusanagi 1.3 enddo
1031 kusanagi 2.5 call clearall
1032 kusanagi 1.3 endif
1033     c
1034     999 continue
1035 kusanagi 2.1 c
1036 kusanagi 1.8 do l = 1, 4
1037     do bit=0, 31
1038     if (bit.lt.16) then
1039     bi = ibits(E2(L),bit,1)
1040 kusanagi 2.2 elseif (bit.gt.17) then
1041 kusanagi 1.8 bi = 0
1042 kusanagi 2.2 elseif (bit.ge.16.and.bit.le.17) then
1043     bi = 2
1044 kusanagi 1.8 endif
1045 kusanagi 2.1 if (bi.eq.1) then
1046     stwerr(l) = ibset(stwerr(l),bit)
1047 kusanagi 2.2 elseif (bi.eq.0) then
1048 kusanagi 2.1 stwerr(l) = ibclr(stwerr(l),bit)
1049     endif
1050 kusanagi 1.8 enddo
1051     perror(l) = float(merror(l))
1052 kusanagi 1.7 enddo
1053 kusanagi 2.1 c
1054 kusanagi 2.10 if ( iev.eq.dumpo ) then
1055     if (perror(3).eq.132.and.perror(4).eq.129) then
1056     do i = 1, 2
1057     do j = 1, 22
1058     do l = 1, 96
1059     print *,'Evento ',i,j,l,dexy(i,j,l)
1060     enddo
1061     enddo
1062     enddo
1063     do l=1,lung
1064     write(*,17)l,vecta(l)
1065     enddo
1066     endif
1067     endif
1068     iev = iev + 1
1069 kusanagi 1.3 RETURN
1070     END
1071    
1072    
1073     C------------------------------------------------
1074     SUBROUTINE CALRAW(vect,inf,sup,dedx)
1075     C------------------------------------------------
1076    
1077     IMPLICIT NONE
1078 kusanagi 2.2 C
1079     INTEGER NPLA, NCHA, LENSEV
1080     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1081     C
1082 kusanagi 1.7 INTEGER*2 VECT(30000)
1083 kusanagi 1.3 INTEGER inf, sup
1084 kusanagi 2.6 INTEGER i,j,k, iev
1085 kusanagi 2.2 INTEGER contr
1086 kusanagi 2.8 integer stwerr(4), dumpo, merror(4)
1087 kusanagi 1.3 C
1088 kusanagi 2.2 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1089 kusanagi 2.5 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1090 kusanagi 1.3 & calDSPtaberr(4), calevnum(4)
1091     REAL dedx(11,96)
1092 kusanagi 2.6 real perror(4)
1093 kusanagi 2.2 C
1094 kusanagi 2.6 COMMON / evento / iev, stwerr, perror,
1095 kusanagi 1.3 & dexy,dexyc,base,
1096     & calselftrig,calIItrig,
1097 kusanagi 2.5 & calstriphit,calDSPtaberr,calevnum
1098 kusanagi 1.3
1099     save / evento /
1100     c
1101 kusanagi 2.8 COMMON / VARIE / dumpo, CONTR, merror
1102 kusanagi 1.3 SAVE / VARIE /
1103 kusanagi 2.2 c
1104 kusanagi 1.3 k = inf
1105     do j = 1,96
1106     do i = 1,11
1107 kusanagi 2.2 DEDX(I,J) = 0.
1108 kusanagi 1.3 dedx(i,j) = vect(k)
1109     k = k + 1
1110     enddo
1111     enddo
1112     c
1113     RETURN
1114     END
1115    
1116     C------------------------------------------------
1117     SUBROUTINE CALCOMPRESS(vect,inf,sup,dedx,basse)
1118     C------------------------------------------------
1119    
1120     IMPLICIT NONE
1121    
1122 kusanagi 2.2 INTEGER NPLA, NCHA, LENSEV
1123     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1124 kusanagi 1.3 C
1125 kusanagi 2.2 INTEGER*2 VECT(30000)
1126 kusanagi 2.10 INTEGER*2 st, st1
1127 kusanagi 1.3 INTEGER inf, sup
1128 kusanagi 2.6 INTEGER i,j, iev
1129 kusanagi 1.3 INTEGER ib
1130     INTEGER ipl, ipr, ist
1131     INTEGER merror(4)
1132     INTEGER contr
1133 kusanagi 2.2 integer stwerr(4),dumpo
1134 kusanagi 2.8 integer bit,bi
1135 kusanagi 2.2 C
1136     REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1137 kusanagi 2.5 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1138 kusanagi 1.3 & calDSPtaberr(4), calevnum(4)
1139     REAL dedx(11,96), basse(11,6)
1140 kusanagi 2.6 real perror(4)
1141 kusanagi 1.3 C
1142 kusanagi 1.8 COMMON / evento / IEV, stwerr,perror,
1143 kusanagi 1.3 & dexy,dexyc,base,
1144     & calselftrig,calIItrig,
1145 kusanagi 2.5 & calstriphit,calDSPtaberr,calevnum
1146 kusanagi 1.3
1147     save / evento /
1148     c
1149 kusanagi 2.8 COMMON / VARIE / dumpo, CONTR, merror
1150 kusanagi 1.3 SAVE / VARIE /
1151    
1152     C
1153     DO I = 1,11
1154     DO J = 1,96
1155 kusanagi 2.2 if (j.le.6) basse(i,j) = 0.
1156 kusanagi 1.3 DEDX(I,J) = 0.
1157     ENDDO
1158     ENDDO
1159     C
1160 kusanagi 1.5 i = inf
1161     c
1162 kusanagi 1.3 10 continue
1163 kusanagi 1.6 if (i.gt.sup) then
1164     RETURN
1165     endif
1166 kusanagi 1.3 C
1167     40 format(2x,i5,2x,'status :',1x,Z4)
1168 kusanagi 1.5 C
1169     c
1170     st1 = 0
1171 kusanagi 2.8 do bit=0, 7
1172     bi = ibits(vect(i),bit+8,1)
1173     if (bi.eq.1) st1 = ibset(st1,bit)
1174     enddo
1175     43 format(2x,'vect(i) = ',Z8)
1176     if (st1.eq.8) then
1177 kusanagi 1.3 ib = 1
1178     else
1179 kusanagi 2.8 if (st1.eq.16) then
1180 kusanagi 1.3 ib = 0
1181     else
1182 kusanagi 2.1 if (iev.eq.dumpo) then
1183 kusanagi 1.9 print *,'i ',i
1184     write(*,43)vect(i)
1185     endif
1186 kusanagi 1.5 merror(contr) = 139
1187 kusanagi 1.3 RETURN
1188     endif
1189     endif
1190     C
1191     if (ib.eq.1) then
1192 kusanagi 1.6 C
1193 kusanagi 1.3 st = IAND(vect(i),'00FF'x)
1194 kusanagi 1.5 c
1195 kusanagi 1.3 ipl = int(st/6) + 1
1196 kusanagi 1.5 ipr = st - (ipl - 1) * 6 + 1
1197 kusanagi 1.3 i = i + 1
1198 kusanagi 1.6 if (i.gt.sup) RETURN
1199 kusanagi 1.3 basse(ipl,ipr) = vect(i)
1200 kusanagi 1.6 c
1201 kusanagi 1.3 20 continue
1202     if (i.gt.sup) RETURN
1203     C
1204     i = i + 1
1205 kusanagi 1.6 if (i.gt.sup) RETURN
1206     if ((vect(i)+1).gt.16.or.(vect(i)+1).lt.1) then
1207 kusanagi 2.8
1208 kusanagi 1.6 goto 10
1209     endif
1210     ist = vect(i) + 1 + 16 * (ipr - 1)
1211 kusanagi 1.3 i = i + 1
1212 kusanagi 1.6 if (i.gt.sup) RETURN
1213 kusanagi 1.5 dedx(ipl,ist) = vect(i)
1214 kusanagi 1.6 goto 20
1215 kusanagi 1.3 else
1216     C
1217     st = IAND(vect(i),'00FF'x)
1218 kusanagi 1.6 ipl = int(st/6) + 1
1219 kusanagi 1.5 ipr = st - (ipl - 1) * 6 + 1
1220 kusanagi 1.3 do j = 1,16
1221     i = i + 1
1222 kusanagi 1.6 if (i.gt.sup) RETURN
1223     ist = j + 16 * (ipr - 1)
1224     dedx(ipl,ist) = vect(i)
1225 kusanagi 1.3 enddo
1226 kusanagi 1.6 i = i + 1
1227     if (i.gt.sup) RETURN
1228 kusanagi 1.3 goto 10
1229     C
1230     endif
1231    
1232    
1233     RETURN
1234     END
1235    
1236    
1237 kusanagi 1.5 C----------------------------------------------------------
1238 kusanagi 1.3 SUBROUTINE CALFULL(vect,inf,sup,dedx,dedxc,basse)
1239 kusanagi 1.5 C--------------------------------------------------------------
1240 kusanagi 1.3
1241     IMPLICIT NONE
1242    
1243 kusanagi 2.2 INTEGER NPLA, NCHA, LENSEV
1244     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1245     C
1246 kusanagi 1.7 INTEGER*2 VECT(30000)
1247 kusanagi 1.3 INTEGER inf, sup
1248 kusanagi 2.6 INTEGER i,j,k, iev
1249 kusanagi 2.2 INTEGER contr
1250 kusanagi 2.8 integer stwerr(4),dumpo,merror(4)
1251 kusanagi 1.3 C
1252 kusanagi 2.2 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1253 kusanagi 2.5 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1254 kusanagi 1.3 & calDSPtaberr(4), calevnum(4)
1255     REAL dedx(11,96), basse(11,6), dedxc(11,96)
1256 kusanagi 2.6 real perror(4)
1257 kusanagi 2.2 C
1258 kusanagi 2.6 COMMON / evento / iev, stwerr,perror,
1259 kusanagi 1.3 & dexy,dexyc,base,
1260     & calselftrig,calIItrig,
1261 kusanagi 2.5 & calstriphit,calDSPtaberr,calevnum
1262 kusanagi 1.3
1263     save / evento /
1264     c
1265 kusanagi 2.8 COMMON / VARIE / dumpo, CONTR, merror
1266 kusanagi 1.3 SAVE / VARIE /
1267     C
1268 kusanagi 1.6 k = inf
1269 kusanagi 1.3 do i = 1,11
1270     do j = 1,96
1271 kusanagi 2.2 DEDX(I,J) = 0.
1272 kusanagi 1.3 dedx(i,j) = vect(k)
1273     k = k + 1
1274     enddo
1275     enddo
1276     C
1277     call CALCOMPRESS(vect,k,sup,dedxc,basse)
1278 kusanagi 1.6 C
1279     10 FORMAT(2X,'Status word:',2X,Z8)
1280 kusanagi 1.3
1281     RETURN
1282     END
1283    
1284    
1285     C------------------------------------------------
1286 kusanagi 2.5 SUBROUTINE COUNTER(ve,er)
1287 kusanagi 1.3 C------------------------------------------------
1288    
1289     IMPLICIT NONE
1290    
1291     INTEGER NPLA, NCHA, LENSEV
1292     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1293 kusanagi 2.2 C
1294     INTEGER*2 VE, st4
1295 kusanagi 2.6 INTEGER er, bit, bi, iev
1296 kusanagi 1.3 INTEGER contr
1297 kusanagi 2.8 integer stwerr(4),dumpo, merror(4)
1298 kusanagi 2.2 C
1299     REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1300 kusanagi 2.5 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1301 kusanagi 2.2 & calDSPtaberr(4), calevnum(4)
1302 kusanagi 2.6 real perror(4)
1303 kusanagi 2.2 C
1304 kusanagi 1.8 COMMON / evento / IEV, stwerr,perror,
1305 kusanagi 1.3 & dexy,dexyc,base,
1306     & calselftrig,calIItrig,
1307 kusanagi 2.5 & calstriphit,calDSPtaberr,calevnum
1308 kusanagi 1.3
1309     save / evento /
1310    
1311 kusanagi 2.8 COMMON / VARIE / dumpo, CONTR, merror
1312 kusanagi 1.3 SAVE / VARIE /
1313    
1314    
1315     st4 = 0
1316     st4 = IAND(ve,'00FF'x)
1317     if (st4.ne.0) then
1318     do bit=0, 6
1319     bi = ibits(st4,bit,1)
1320     if (bi.ne.0) then
1321 kusanagi 2.2 er = er + 2
1322 kusanagi 1.3 endif
1323     enddo
1324     endif
1325    
1326     10 FORMAT(2X,'Status word:',2X,Z4)
1327     return
1328     end
1329    
1330    
1331     C------------------------------------------------
1332     SUBROUTINE MINERR(ic,icsave,chi,min,co)
1333     C------------------------------------------------
1334    
1335     IMPLICIT NONE
1336     C
1337 kusanagi 2.2 INTEGER NPLA, NCHA, LENSEV
1338     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1339     C
1340 kusanagi 1.3 INTEGER ic, icsave(1000), chi(1000)
1341     integer l, st, min,co
1342 kusanagi 2.6 INTEGER iev
1343 kusanagi 2.2 INTEGER contr
1344 kusanagi 2.8 integer stwerr(4),dumpo, merror(4)
1345 kusanagi 1.3 C
1346 kusanagi 2.2 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1347 kusanagi 2.5 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1348 kusanagi 2.2 & calDSPtaberr(4), calevnum(4)
1349 kusanagi 2.6 real perror(4)
1350 kusanagi 2.2 C
1351 kusanagi 2.6 COMMON / evento / iev, stwerr,perror,
1352 kusanagi 1.3 & dexy,dexyc,base,
1353     & calselftrig,calIItrig,
1354 kusanagi 2.5 & calstriphit,calDSPtaberr,calevnum
1355 kusanagi 1.3
1356     save / evento /
1357 kusanagi 2.6 C
1358 kusanagi 2.8 COMMON / VARIE / dumpo, CONTR, merror
1359 kusanagi 1.3 SAVE / VARIE /
1360    
1361     st = chi(1)
1362     min = 1
1363     if (co.gt.1) then
1364     do l = 2, co
1365     if (chi(l).lt.st) then
1366     st = chi(l)
1367     min = l
1368     endif
1369     enddo
1370     endif
1371     ic = icsave(min)
1372    
1373     return
1374     end
1375 kusanagi 1.7
1376     C-----------------------------------------------------
1377 kusanagi 2.5 SUBROUTINE CLEARSEC
1378 kusanagi 1.7 C-----------------------------------------------------
1379    
1380     IMPLICIT NONE
1381     C
1382     INTEGER NPLA, NCHA, LENSEV
1383     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1384 kusanagi 2.2 C
1385 kusanagi 2.6 INTEGER iev
1386 kusanagi 2.5 INTEGER contr, i,j
1387 kusanagi 2.8 integer stwerr(4),dumpo, merror(4)
1388 kusanagi 2.2 C
1389     REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1390 kusanagi 2.5 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1391 kusanagi 1.7 & calDSPtaberr(4), calevnum(4)
1392 kusanagi 2.6 real perror(4)
1393 kusanagi 2.2 C
1394 kusanagi 2.6 COMMON / evento / iev, stwerr,perror,
1395 kusanagi 1.7 & dexy,dexyc,base,
1396     & calselftrig,calIItrig,
1397 kusanagi 2.5 & calstriphit,calDSPtaberr,calevnum
1398 kusanagi 1.7
1399     save / evento /
1400     c
1401 kusanagi 2.8 COMMON / VARIE / dumpo, CONTR, merror
1402 kusanagi 2.5 SAVE / VARIE /
1403 kusanagi 1.7 C
1404 kusanagi 2.5 DO I = 1,11
1405     DO J = 1,96
1406 kusanagi 2.10 if (contr.eq.3) then
1407 kusanagi 2.5 DEXY(1,2*I,J) = 0.
1408     DEXYC(1,2*I,J) = 0.
1409     endif
1410 kusanagi 2.10 if (contr.eq.4) then
1411 kusanagi 2.5 DEXY(1,2*I-1,J) = 0.
1412     DEXYC(1,2*I-1,J) = 0.
1413     endif
1414 kusanagi 2.10 if (contr.eq.1) then
1415 kusanagi 2.5 DEXY(2,2*I-1,97-J) = 0.
1416     DEXYC(2,2*I-1,97-J) = 0.
1417     endif
1418 kusanagi 2.10 if (contr.eq.2) then
1419 kusanagi 2.5 DEXY(2,2*I,J) = 0.
1420     DEXYC(2,2*I,J) = 0.
1421     endif
1422     enddo
1423     do j = 1,6
1424 kusanagi 2.10 if (contr.eq.1) base(2,2*i-1,7-j) = 0.
1425     if (contr.eq.4) base(1,2*i-1,j) = 0.
1426     if (contr.eq.2) base(2,2*i,j) = 0.
1427     if (contr.eq.3) base(1,2*i,j) = 0.
1428 kusanagi 2.5 enddo
1429     if (i.le.7) calselftrig(contr,i) = 0.
1430     enddo
1431     calIItrig(contr) = 0.
1432     calstriphit(contr) = 0.
1433     calDSPtaberr(contr) = 0.
1434     calevnum(contr) = 0.
1435     return
1436 kusanagi 1.7 end
1437 kusanagi 2.5 C

  ViewVC Help
Powered by ViewVC 1.1.23