/[PAMELA software]/chewbacca/PamOffLineSW/forroutines/calorimeter/calunpack.for
ViewVC logotype

Annotation of /chewbacca/PamOffLineSW/forroutines/calorimeter/calunpack.for

Parent Directory Parent Directory | Revision Log Revision Log

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