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