/[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.7 - (hide annotations) (download)
Thu Dec 24 10:31:14 2009 UTC (14 years, 11 months ago) by mocchiut
Branch: MAIN
Changes since 1.6: +18 -2 lines 
New version, packages recovering tools implemented, new DB, bugs 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.7 c dumpo=iev
207 mocchiut 1.4 c if (iev.eq.dumpo) then
208     c do l=1,lung
209     c write(*,17)l,vecta(l)
210     c enddo
211     c endif
212 mocchiut 1.1 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.7
1134     c
1135     c should never happen that we find MORE than 4 sections..
1136     c
1137     if (contr.gt.4) then
1138     if (iev.eq.dumpo)
1139     & print *,'contr ????????????? ',contr
1140    
1141     me = 1
1142     do i = 1, 4
1143     merror(i) = 129
1144     e2(i) = 0
1145     stwerr(i) = 0
1146     enddo
1147     call clearall
1148     goto 999
1149     endif
1150 mocchiut 1.2 c
1151     c in case of crc error proceed as if we never processed this section
1152     c
1153     if ( scrcerr.eq.1 ) then
1154    
1155     chi = chi + 4
1156     lleng = 0
1157     length2 = 0
1158     length = 0
1159     c
1160     headcor = 1
1161     ichc = sic - 1
1162     icb = sicb
1163     if (iev.eq.dumpo)
1164 mocchiut 1.4 & print *,' B crc is wrong ',sic,
1165 mocchiut 1.2 & ' search section ',contr,' coco = ',coco
1166     goto 32
1167     c
1168     endif
1169    
1170 mocchiut 1.1 C
1171     c go on till we have found all the four sections
1172     c
1173     if (contr.lt.5) goto 20
1174     c
1175     200 continue
1176     C
1177     iscomp = 0
1178     isfull = 0
1179     israw = 0
1180     do i = 1, 4
1181     if (ibits(stwerr(i),16,1).eq.1) iscomp = iscomp + 1
1182     if (ibits(stwerr(i),17,1).eq.1) isfull = isfull + 1
1183     if (ibits(e2(i),3,1).eq.1) israw = israw + 1
1184     enddo
1185     if (iscomp.ne.0) chi = chi + 8 * (4 - iscomp)
1186     if (israw.ne.0) chi = chi + 8 * (4 - israw)
1187     if (isfull.ne.0) chi = chi + 8 * (4 - isfull)
1188     C
1189     C if chi>10 and we have information enough to understand the physic event
1190     C was acquired in a certain mode (RAW, FULL or COMPRESS) then reprocess
1191     C the event using this information, sometimes we miss a section due to
1192     C CRC errors in the previous one but if we know what we are looking for
1193     C then it is possible to save this kind of events.
1194     C
1195     if (chi.gt.5.and.yesisco.eq.0.and.yesisfu.eq.0
1196     & .and.yesisra.eq.0.and.yescbra.eq.0) then
1197     israw = 0
1198     cberaw = 0
1199     do i = 1, 4
1200     if (ibits(e2(i),3,1).eq.1.and.merror(i).eq.0)
1201     & israw = israw + 1
1202     if (ibits(e2(i),3,1).eq.1.and.merror(i).eq.132)
1203     & cberaw = cberaw + 1
1204     enddo
1205     yesisco = 0
1206     yesisfu = 0
1207     yesisra = 0
1208     yescbra = 0
1209     if (iscomp.ne.0) yesisco = 1
1210     if (isfull.ne.0) yesisfu = 1
1211     if (israw.ne.0) yesisra = 1
1212     if (cberaw.ne.0) yescbra = 1
1213     if ((yesisco+yesisfu+yesisra).eq.1.or.
1214     & ((yesisco+yesisfu+yesisra).eq.0.and.yescbra.eq.1)) then
1215     if (iev.eq.dumpo) then
1216     print *,'************************'
1217     if (iscomp.ne.0) print *,'is a compress acq.'
1218     if (isfull.ne.0) print *,'is a full acq.'
1219     if (israw.ne.0) print *,'is a raw acq.'
1220     if (israw.eq.0.and.cberaw.ne.0)
1221     & print *,'could be a raw acq.'
1222     print *,'so, SGARBUF, do it again! ',chi
1223     print *,'************************'
1224     endif
1225     SOGLIA0 = SOGLIA0 - ISCOMP - ISFULL - ISRAW
1226     goto 1
1227     endif
1228     if ((yesisco+yesisfu+yesisra+yescbra).eq.0) chi = 1000
1229     endif
1230     C
1231     if (iev.eq.dumpo)
1232     & print *,'chi <= soglia0 ?',chi,soglia0
1233     if (chi.lt.soglia0) then
1234     me = 0
1235     else
1236     me = 1
1237     do i = 1, 4
1238     merror(i) = 129
1239     e2(i) = 0
1240     stwerr(i) = 0
1241     enddo
1242     call clearall
1243     goto 999
1244     endif
1245     C
1246     C if all section are missing clear vectors and go out
1247     C
1248     if (merror(1).eq.129.and.merror(2).eq.129
1249     & .and.merror(3).eq.129.and.merror(4).eq.129) then
1250     do l = 1,4
1251     e2(l) = 0
1252     stwerr(l) = 0
1253     enddo
1254     call clearall
1255     endif
1256     c
1257     999 continue
1258     c
1259     do l = 1, 4
1260     do bit=0, 31
1261     if (bit.lt.16) then
1262     bi = ibits(E2(L),bit,1)
1263     elseif (bit.gt.17) then
1264     bi = 0
1265     elseif (bit.ge.16.and.bit.le.17) then
1266     bi = 2
1267     endif
1268     if (bi.eq.1) then
1269     stwerr(l) = ibset(stwerr(l),bit)
1270     elseif (bi.eq.0) then
1271     stwerr(l) = ibclr(stwerr(l),bit)
1272     endif
1273     enddo
1274     perror(l) = float(merror(l))
1275     enddo
1276     c
1277     if ( iev.eq.dumpo ) then
1278     do i = 1, 4
1279     print *,' perror(',i,') = ',perror(i)
1280     print *,' stwerr(',i,') = ',stwerr(i)
1281     enddo
1282     if (perror(3).eq.132.and.perror(4).eq.129) then
1283     do i = 1, 2
1284     do j = 1, 22
1285     do l = 1, 96
1286     print *,'Evento ',i,j,l,dexy(i,j,l)
1287     enddo
1288     enddo
1289     enddo
1290     endif
1291 mocchiut 1.4 c do l=1,lung
1292     c write(*,17)l,vecta(l)
1293     c enddo
1294 mocchiut 1.1 endif
1295     iev = iev + 1
1296     RETURN
1297     END
1298    
1299    
1300     C------------------------------------------------
1301     SUBROUTINE CALRAW(vect,inf,sup,dedx)
1302     C------------------------------------------------
1303    
1304     IMPLICIT NONE
1305     C
1306     INTEGER NPLA, NCHA, LENSEV
1307     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1308     C
1309     INTEGER*2 VECT(30000)
1310     INTEGER inf, sup
1311     INTEGER i,j,k, iev
1312     INTEGER contr
1313     integer stwerr(4), dumpo, merror(4)
1314     C
1315     REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1316     real calselftrig(4,7), calIItrig(4), calstriphit(4),
1317     & calDSPtaberr(4), calevnum(4)
1318     REAL dedx(11,96)
1319     real perror(4)
1320     C
1321     COMMON / evento / iev, stwerr, perror,
1322     & dexy,dexyc,base,
1323     & calselftrig,calIItrig,
1324     & calstriphit,calDSPtaberr,calevnum
1325    
1326     save / evento /
1327     c
1328     COMMON / VARIE / dumpo, CONTR, merror
1329     SAVE / VARIE /
1330     c
1331     k = inf
1332     do j = 1,96
1333     do i = 1,11
1334     DEDX(I,J) = 0.
1335 mocchiut 1.2 if ( k.le.120000 ) dedx(i,j) = vect(k)
1336 mocchiut 1.1 k = k + 1
1337     enddo
1338     enddo
1339     c
1340     RETURN
1341     END
1342    
1343     C------------------------------------------------
1344 mocchiut 1.2 SUBROUTINE CALCOMPRESS(vect,inf,sup,dedx,basse,cer)
1345 mocchiut 1.1 C------------------------------------------------
1346    
1347     IMPLICIT NONE
1348    
1349     INTEGER NPLA, NCHA, LENSEV
1350     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1351     C
1352     INTEGER*2 VECT(30000)
1353     INTEGER*2 st, st1
1354     INTEGER inf, sup
1355     INTEGER i,j, iev
1356     INTEGER ib
1357     INTEGER ipl, ipr, ist
1358     INTEGER merror(4)
1359     INTEGER contr
1360     integer stwerr(4),dumpo
1361 mocchiut 1.2 integer bit,bi,cer
1362 mocchiut 1.1 C
1363     REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1364     real calselftrig(4,7), calIItrig(4), calstriphit(4),
1365     & calDSPtaberr(4), calevnum(4)
1366     REAL dedx(11,96), basse(11,6)
1367     real perror(4)
1368     C
1369     COMMON / evento / IEV, stwerr,perror,
1370     & dexy,dexyc,base,
1371     & calselftrig,calIItrig,
1372     & calstriphit,calDSPtaberr,calevnum
1373    
1374     save / evento /
1375     c
1376     COMMON / VARIE / dumpo, CONTR, merror
1377     SAVE / VARIE /
1378    
1379     C
1380     DO I = 1,11
1381     DO J = 1,96
1382     if (j.le.6) basse(i,j) = 0.
1383     DEDX(I,J) = 0.
1384     ENDDO
1385     ENDDO
1386     C
1387     i = inf
1388     c
1389     10 continue
1390 mocchiut 1.3 if (i.gt.sup.or.i.gt.120000) then
1391 mocchiut 1.1 RETURN
1392     endif
1393     C
1394     40 format(2x,i5,2x,'status :',1x,Z4)
1395     C
1396     c
1397     st1 = 0
1398     do bit=0, 7
1399     bi = ibits(vect(i),bit+8,1)
1400     if (bi.eq.1) st1 = ibset(st1,bit)
1401     enddo
1402     43 format(2x,'vect(i) = ',Z8)
1403     if (st1.eq.8) then
1404     ib = 1
1405     else
1406     if (st1.eq.16) then
1407     ib = 0
1408     else
1409     if (iev.eq.dumpo) then
1410     print *,'i ',i
1411     write(*,43)vect(i)
1412     endif
1413     merror(contr) = 139
1414 mocchiut 1.2 if ( cer.eq.0 ) then
1415     RETURN
1416     else
1417     i = i + 1
1418     goto 10
1419     endif
1420 mocchiut 1.1 endif
1421     endif
1422     C
1423     if (ib.eq.1) then
1424     C
1425     st = IAND(vect(i),'00FF'x)
1426     c
1427     ipl = int(st/6) + 1
1428     ipr = st - (ipl - 1) * 6 + 1
1429     i = i + 1
1430 mocchiut 1.3 if (i.gt.sup.or.i.gt.120000) RETURN
1431 mocchiut 1.2 if ( ipl.ge.1.and.ipl.le.11.and.ipr.ge.1.and.ipr.le.6)
1432     + basse(ipl,ipr) = vect(i)
1433 mocchiut 1.1 c
1434     20 continue
1435 mocchiut 1.3 if (i.gt.sup.or.i.gt.120000) RETURN
1436 mocchiut 1.1 C
1437     i = i + 1
1438 mocchiut 1.3 if (i.gt.sup.or.i.gt.120000) RETURN
1439 mocchiut 1.1 if ((vect(i)+1).gt.16.or.(vect(i)+1).lt.1) then
1440     goto 10
1441     endif
1442     ist = vect(i) + 1 + 16 * (ipr - 1)
1443     i = i + 1
1444 mocchiut 1.3 if (i.gt.sup.or.i.gt.120000) RETURN
1445 mocchiut 1.2 if ( ipl.ge.1.and.ipl.le.11.and.ist.ge.1.and.ist.le.96)
1446     + dedx(ipl,ist) = vect(i)
1447 mocchiut 1.1 goto 20
1448     else
1449     C
1450     st = IAND(vect(i),'00FF'x)
1451     ipl = int(st/6) + 1
1452     ipr = st - (ipl - 1) * 6 + 1
1453 mocchiut 1.2 if ( ipl.ge.1.and.ipl.le.11 ) then
1454     do j = 1,16
1455     i = i + 1
1456 mocchiut 1.3 if (i.gt.sup.or.i.gt.120000) RETURN
1457 mocchiut 1.2 ist = j + 16 * (ipr - 1)
1458     if (ist.ge.1.and.ist.le.96) dedx(ipl,ist) = vect(i)
1459     enddo
1460     endif
1461 mocchiut 1.1 i = i + 1
1462 mocchiut 1.3 if (i.gt.sup.or.i.gt.120000) RETURN
1463 mocchiut 1.1 goto 10
1464     C
1465     endif
1466    
1467    
1468     RETURN
1469     END
1470    
1471    
1472     C----------------------------------------------------------
1473 mocchiut 1.2 SUBROUTINE CALFULL(vect,inf,sup,dedx,dedxc,basse,cer)
1474 mocchiut 1.1 C--------------------------------------------------------------
1475    
1476     IMPLICIT NONE
1477    
1478     INTEGER NPLA, NCHA, LENSEV
1479     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1480     C
1481     INTEGER*2 VECT(30000)
1482     INTEGER inf, sup
1483 mocchiut 1.2 INTEGER i,j,k, iev, cer
1484 mocchiut 1.1 INTEGER contr
1485     integer stwerr(4),dumpo,merror(4)
1486     C
1487     REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1488     real calselftrig(4,7), calIItrig(4), calstriphit(4),
1489     & calDSPtaberr(4), calevnum(4)
1490     REAL dedx(11,96), basse(11,6), dedxc(11,96)
1491     real perror(4)
1492     C
1493     COMMON / evento / iev, stwerr,perror,
1494     & dexy,dexyc,base,
1495     & calselftrig,calIItrig,
1496     & calstriphit,calDSPtaberr,calevnum
1497    
1498     save / evento /
1499     c
1500     COMMON / VARIE / dumpo, CONTR, merror
1501     SAVE / VARIE /
1502     C
1503     k = inf
1504     do i = 1,11
1505     do j = 1,96
1506     DEDX(I,J) = 0.
1507 mocchiut 1.2 if ( k.le.120000 ) dedx(i,j) = vect(k)
1508 mocchiut 1.1 k = k + 1
1509     enddo
1510     enddo
1511     C
1512 mocchiut 1.2 call CALCOMPRESS(vect,k,sup,dedxc,basse,cer)
1513 mocchiut 1.1 C
1514     10 FORMAT(2X,'Status word:',2X,Z8)
1515    
1516     RETURN
1517     END
1518    
1519    
1520     C------------------------------------------------
1521     SUBROUTINE COUNTER(ve,er)
1522     C------------------------------------------------
1523    
1524     IMPLICIT NONE
1525    
1526     INTEGER NPLA, NCHA, LENSEV
1527     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1528     C
1529     INTEGER*2 VE, st4
1530     INTEGER er, bit, bi, iev
1531     INTEGER contr
1532     integer stwerr(4),dumpo, merror(4)
1533     C
1534     REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1535     real calselftrig(4,7), calIItrig(4), calstriphit(4),
1536     & calDSPtaberr(4), calevnum(4)
1537     real perror(4)
1538     C
1539     COMMON / evento / IEV, stwerr,perror,
1540     & dexy,dexyc,base,
1541     & calselftrig,calIItrig,
1542     & calstriphit,calDSPtaberr,calevnum
1543    
1544     save / evento /
1545    
1546     COMMON / VARIE / dumpo, CONTR, merror
1547     SAVE / VARIE /
1548    
1549    
1550     st4 = 0
1551     st4 = IAND(ve,'00FF'x)
1552     if (st4.ne.0) then
1553     do bit=0, 6
1554     bi = ibits(st4,bit,1)
1555     if (bi.ne.0) then
1556     er = er + 2
1557     endif
1558     enddo
1559     endif
1560    
1561     10 FORMAT(2X,'Status word:',2X,Z4)
1562     return
1563     end
1564    
1565    
1566     C------------------------------------------------
1567     SUBROUTINE MINERR(ic,icsave,chi,min,co)
1568     C------------------------------------------------
1569    
1570     IMPLICIT NONE
1571     C
1572     INTEGER NPLA, NCHA, LENSEV
1573     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1574     C
1575     INTEGER ic, icsave(1000), chi(1000)
1576     integer l, st, min,co
1577     INTEGER iev
1578     INTEGER contr
1579     integer stwerr(4),dumpo, merror(4)
1580     C
1581     REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1582     real calselftrig(4,7), calIItrig(4), calstriphit(4),
1583     & calDSPtaberr(4), calevnum(4)
1584     real perror(4)
1585     C
1586     COMMON / evento / iev, stwerr,perror,
1587     & dexy,dexyc,base,
1588     & calselftrig,calIItrig,
1589     & calstriphit,calDSPtaberr,calevnum
1590    
1591     save / evento /
1592     C
1593     COMMON / VARIE / dumpo, CONTR, merror
1594     SAVE / VARIE /
1595    
1596     st = chi(1)
1597     min = 1
1598     if (co.gt.1) then
1599     do l = 2, co
1600     if (chi(l).lt.st) then
1601     st = chi(l)
1602     min = l
1603     endif
1604     enddo
1605     endif
1606     ic = icsave(min)
1607    
1608     return
1609     end
1610    
1611     C-----------------------------------------------------
1612     SUBROUTINE CLEARSEC
1613     C-----------------------------------------------------
1614    
1615     IMPLICIT NONE
1616     C
1617     INTEGER NPLA, NCHA, LENSEV
1618     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1619     C
1620     INTEGER iev
1621     INTEGER contr, i,j
1622     integer stwerr(4),dumpo, merror(4)
1623     C
1624     REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1625     real calselftrig(4,7), calIItrig(4), calstriphit(4),
1626     & calDSPtaberr(4), calevnum(4)
1627     real perror(4)
1628     C
1629     COMMON / evento / iev, stwerr,perror,
1630     & dexy,dexyc,base,
1631     & calselftrig,calIItrig,
1632     & calstriphit,calDSPtaberr,calevnum
1633    
1634     save / evento /
1635     c
1636     COMMON / VARIE / dumpo, CONTR, merror
1637     SAVE / VARIE /
1638     C
1639     DO I = 1,11
1640     DO J = 1,96
1641     if (contr.eq.3) then
1642     DEXY(1,2*I,J) = 0.
1643     DEXYC(1,2*I,J) = 0.
1644     endif
1645     if (contr.eq.4) then
1646     DEXY(1,2*I-1,J) = 0.
1647     DEXYC(1,2*I-1,J) = 0.
1648     endif
1649     if (contr.eq.1) then
1650     DEXY(2,2*I-1,J) = 0.
1651     DEXYC(2,2*I-1,J) = 0.
1652     endif
1653     if (contr.eq.2) then
1654     DEXY(2,2*I,97-J) = 0.
1655     DEXYC(2,2*I,97-J) = 0.
1656     endif
1657     enddo
1658     do j = 1,6
1659     if (contr.eq.1) base(2,2*i-1,7-j) = 0.
1660     if (contr.eq.4) base(1,2*i-1,j) = 0.
1661     if (contr.eq.2) base(2,2*i,j) = 0.
1662     if (contr.eq.3) base(1,2*i,j) = 0.
1663     enddo
1664     if (i.le.7) calselftrig(contr,i) = 0.
1665     enddo
1666     calIItrig(contr) = 0.
1667     calstriphit(contr) = 0.
1668     calDSPtaberr(contr) = 0.
1669     calevnum(contr) = 0.
1670     return
1671     end
1672     C
  ViewVC Help
Powered by ViewVC 1.1.23