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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations) (download)
Wed Dec 23 07:04:29 2009 UTC (15 years, 2 months ago) by mocchiut
Branch: MAIN
Changes since 1.5: +8 -1 lines
Compat gcc3/gcc4 bug in calo unpacking fixed

1 C
2 C Written by Emiliano Mocchiutti and Mirko Boezio
3 C
4 C * Version: 3.4.11 *
5 C
6 C Changelog:
7 C
8 C 3.4.10 - 3.4.11: (2008-12-04) Process always the data also in case of CRC errors.
9 C
10 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 c PARAMETER (ival=-32768)
127 c PARAMETER (ival='FFFF'x)
128 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 integer scrcerr, sic, sicb
150 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 c dumpo = iev
177 start = 320
178 firsttime = 1
179 SOGLIA0 = 70
180 sic = 0
181 sicb = 0
182 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
194 do bit = 0, 15
195 ival = ibset(ival,bit)
196 enddo
197 c print *,' IVAL ',IVAL
198 c write(*,22)IVAL
199 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 c if (iev.eq.dumpo) then
207 c do l=1,lung
208 c write(*,17)l,vecta(l)
209 c enddo
210 c endif
211 C dumpo = iev
212 C
213 C DETERMINE LENGTH IN WORDS FROM LENGTH IN BYTES
214 C
215 IF (MOD(LUNG,2).EQ.0) THEN
216 lunga = lung / 2
217 pari = 1
218 else
219 lunga = int(lung/2) + 1
220 endif
221 SEC2ND = LUNGA
222 C
223 C IS LENGTH IS TOO LONG?
224 C
225 if (lunga.ge.60000.and.dumpo.gt.0) then
226 print *,'Calorimeter ERROR: more than 60000 words!'
227 endif
228 if (lunga.ge.60000) then
229 if (dumpo.eq.iev) print *,'lung = ',lung
230 do i=1,4
231 merror(i)=143
232 enddo
233 goto 999
234 endif
235 C
236 C PRE-CLEAR VARIABLES
237 C
238 yesisco = 0
239 yesisfu = 0
240 yesisra = 0
241 yescbra = 0
242 C
243 1 CONTINUE
244 c
245 C CLEAR VARIABLES
246 C
247 if (iev.lt.0.or.iev.gt.90000000) iev = 0
248 esci = 0
249 chi = 0
250 chis = 0
251 min = 0
252 lleng = 0
253 m = 0
254 pari = 0
255 icb = 0
256 em = 0
257 coco = 0
258 me = 1
259 contr = 1
260 ic = 1
261 icsave = 0
262 C
263 call clearall
264 call azero(dedx1,11*96)
265 call azero(dedx2,11*96)
266 call azero(dedx3,11*96)
267 call azero(dedx4,11*96)
268 call azero(dedx1c,11*96)
269 call azero(dedx2c,11*96)
270 call azero(dedx3c,11*96)
271 call azero(dedx4c,11*96)
272 call azero(base1,11*6)
273 call azero(base2,11*6)
274 call azero(base3,11*6)
275 call azero(base4,11*6)
276 C
277 do l = 1,4
278 e2(l) = 0
279 perror(l) = 0.
280 stwerr(l) = 0
281 merror(l) = 0
282 enddo
283 C
284 C DETERMINE WHERE TO START TO FIND THE CALORIMETER IN THE INBUT BUFFER
285 C
286 length2 = start
287 c
288 20 continue
289 C
290 if (length2.ge.-2) then
291 ic = ic + (2 * (length2 + 2))
292 else
293 if (dumpo.gt.0)
294 & print *,'Calorimeter WARNING: length errors ',ic,length2
295 endif
296 C
297 headcor = 0
298 ichc = ic
299 icprima = ic
300 hcco = 0
301 do i=1,1000
302 hcchi(i) = 0
303 hcic(i) = 0
304 enddo
305 c
306 32 continue
307 C
308 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 ke = 0
318 chis = chi
319 icold = ic
320 DO i = 1, 120000
321 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 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 C clear vectors of that section in the common
837 C
838 call clearsec
839 C
840 calselftrig(k,1) = check
841 calselftrig(k,2) = vect(length)
842 c
843 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 & print *,' A crc is wrong ',ic,
858 & ' search section ',contr,' coco = ',coco
859 goto 32
860 else
861 c
862 c set some variables and try to go on
863 c
864 merror(contr) = 132
865 scrcerr = 1
866 sic = ic
867 sicb = icb
868
869 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 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 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 if ( scrcerr.eq.0 ) then
909 lleng = 0
910 goto 150
911 endif
912 endif
913 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 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 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 C FIRST CALORIMETER SIGNATURE: CA50
964 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 C SECOND CALORIMETER SIGNATURE: CA50
973 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 C test is here!
982 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 endif
999 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 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 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 C FIRST CALORIMETER SIGNATURE: CA50
1049 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 C SECOND CALORIMETER SIGNATURE: CA50
1058 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 C test is here!
1067 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 endif
1075 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 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 C
1130 150 continue
1131 C
1132 contr = contr + 1
1133
1134 c
1135 c in case of crc error proceed as if we never processed this section
1136 c
1137 if ( scrcerr.eq.1 ) then
1138
1139 chi = chi + 4
1140 lleng = 0
1141 length2 = 0
1142 length = 0
1143 c
1144 headcor = 1
1145 ichc = sic - 1
1146 icb = sicb
1147 if (iev.eq.dumpo)
1148 & print *,' B crc is wrong ',sic,
1149 & ' search section ',contr,' coco = ',coco
1150 goto 32
1151 c
1152 endif
1153
1154 C
1155 c go on till we have found all the four sections
1156 c
1157 if (contr.lt.5) goto 20
1158 c
1159 200 continue
1160 C
1161 iscomp = 0
1162 isfull = 0
1163 israw = 0
1164 do i = 1, 4
1165 if (ibits(stwerr(i),16,1).eq.1) iscomp = iscomp + 1
1166 if (ibits(stwerr(i),17,1).eq.1) isfull = isfull + 1
1167 if (ibits(e2(i),3,1).eq.1) israw = israw + 1
1168 enddo
1169 if (iscomp.ne.0) chi = chi + 8 * (4 - iscomp)
1170 if (israw.ne.0) chi = chi + 8 * (4 - israw)
1171 if (isfull.ne.0) chi = chi + 8 * (4 - isfull)
1172 C
1173 C if chi>10 and we have information enough to understand the physic event
1174 C was acquired in a certain mode (RAW, FULL or COMPRESS) then reprocess
1175 C the event using this information, sometimes we miss a section due to
1176 C CRC errors in the previous one but if we know what we are looking for
1177 C then it is possible to save this kind of events.
1178 C
1179 if (chi.gt.5.and.yesisco.eq.0.and.yesisfu.eq.0
1180 & .and.yesisra.eq.0.and.yescbra.eq.0) then
1181 israw = 0
1182 cberaw = 0
1183 do i = 1, 4
1184 if (ibits(e2(i),3,1).eq.1.and.merror(i).eq.0)
1185 & israw = israw + 1
1186 if (ibits(e2(i),3,1).eq.1.and.merror(i).eq.132)
1187 & cberaw = cberaw + 1
1188 enddo
1189 yesisco = 0
1190 yesisfu = 0
1191 yesisra = 0
1192 yescbra = 0
1193 if (iscomp.ne.0) yesisco = 1
1194 if (isfull.ne.0) yesisfu = 1
1195 if (israw.ne.0) yesisra = 1
1196 if (cberaw.ne.0) yescbra = 1
1197 if ((yesisco+yesisfu+yesisra).eq.1.or.
1198 & ((yesisco+yesisfu+yesisra).eq.0.and.yescbra.eq.1)) then
1199 if (iev.eq.dumpo) then
1200 print *,'************************'
1201 if (iscomp.ne.0) print *,'is a compress acq.'
1202 if (isfull.ne.0) print *,'is a full acq.'
1203 if (israw.ne.0) print *,'is a raw acq.'
1204 if (israw.eq.0.and.cberaw.ne.0)
1205 & print *,'could be a raw acq.'
1206 print *,'so, SGARBUF, do it again! ',chi
1207 print *,'************************'
1208 endif
1209 SOGLIA0 = SOGLIA0 - ISCOMP - ISFULL - ISRAW
1210 goto 1
1211 endif
1212 if ((yesisco+yesisfu+yesisra+yescbra).eq.0) chi = 1000
1213 endif
1214 C
1215 if (iev.eq.dumpo)
1216 & print *,'chi <= soglia0 ?',chi,soglia0
1217 if (chi.lt.soglia0) then
1218 me = 0
1219 else
1220 me = 1
1221 do i = 1, 4
1222 merror(i) = 129
1223 e2(i) = 0
1224 stwerr(i) = 0
1225 enddo
1226 call clearall
1227 goto 999
1228 endif
1229 C
1230 C if all section are missing clear vectors and go out
1231 C
1232 if (merror(1).eq.129.and.merror(2).eq.129
1233 & .and.merror(3).eq.129.and.merror(4).eq.129) then
1234 do l = 1,4
1235 e2(l) = 0
1236 stwerr(l) = 0
1237 enddo
1238 call clearall
1239 endif
1240 c
1241 999 continue
1242 c
1243 do l = 1, 4
1244 do bit=0, 31
1245 if (bit.lt.16) then
1246 bi = ibits(E2(L),bit,1)
1247 elseif (bit.gt.17) then
1248 bi = 0
1249 elseif (bit.ge.16.and.bit.le.17) then
1250 bi = 2
1251 endif
1252 if (bi.eq.1) then
1253 stwerr(l) = ibset(stwerr(l),bit)
1254 elseif (bi.eq.0) then
1255 stwerr(l) = ibclr(stwerr(l),bit)
1256 endif
1257 enddo
1258 perror(l) = float(merror(l))
1259 enddo
1260 c
1261 if ( iev.eq.dumpo ) then
1262 do i = 1, 4
1263 print *,' perror(',i,') = ',perror(i)
1264 print *,' stwerr(',i,') = ',stwerr(i)
1265 enddo
1266 if (perror(3).eq.132.and.perror(4).eq.129) then
1267 do i = 1, 2
1268 do j = 1, 22
1269 do l = 1, 96
1270 print *,'Evento ',i,j,l,dexy(i,j,l)
1271 enddo
1272 enddo
1273 enddo
1274 endif
1275 c do l=1,lung
1276 c write(*,17)l,vecta(l)
1277 c enddo
1278 endif
1279 iev = iev + 1
1280 RETURN
1281 END
1282
1283
1284 C------------------------------------------------
1285 SUBROUTINE CALRAW(vect,inf,sup,dedx)
1286 C------------------------------------------------
1287
1288 IMPLICIT NONE
1289 C
1290 INTEGER NPLA, NCHA, LENSEV
1291 PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1292 C
1293 INTEGER*2 VECT(30000)
1294 INTEGER inf, sup
1295 INTEGER i,j,k, iev
1296 INTEGER contr
1297 integer stwerr(4), dumpo, merror(4)
1298 C
1299 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1300 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1301 & calDSPtaberr(4), calevnum(4)
1302 REAL dedx(11,96)
1303 real perror(4)
1304 C
1305 COMMON / evento / iev, stwerr, perror,
1306 & dexy,dexyc,base,
1307 & calselftrig,calIItrig,
1308 & calstriphit,calDSPtaberr,calevnum
1309
1310 save / evento /
1311 c
1312 COMMON / VARIE / dumpo, CONTR, merror
1313 SAVE / VARIE /
1314 c
1315 k = inf
1316 do j = 1,96
1317 do i = 1,11
1318 DEDX(I,J) = 0.
1319 if ( k.le.120000 ) dedx(i,j) = vect(k)
1320 k = k + 1
1321 enddo
1322 enddo
1323 c
1324 RETURN
1325 END
1326
1327 C------------------------------------------------
1328 SUBROUTINE CALCOMPRESS(vect,inf,sup,dedx,basse,cer)
1329 C------------------------------------------------
1330
1331 IMPLICIT NONE
1332
1333 INTEGER NPLA, NCHA, LENSEV
1334 PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1335 C
1336 INTEGER*2 VECT(30000)
1337 INTEGER*2 st, st1
1338 INTEGER inf, sup
1339 INTEGER i,j, iev
1340 INTEGER ib
1341 INTEGER ipl, ipr, ist
1342 INTEGER merror(4)
1343 INTEGER contr
1344 integer stwerr(4),dumpo
1345 integer bit,bi,cer
1346 C
1347 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1348 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1349 & calDSPtaberr(4), calevnum(4)
1350 REAL dedx(11,96), basse(11,6)
1351 real perror(4)
1352 C
1353 COMMON / evento / IEV, stwerr,perror,
1354 & dexy,dexyc,base,
1355 & calselftrig,calIItrig,
1356 & calstriphit,calDSPtaberr,calevnum
1357
1358 save / evento /
1359 c
1360 COMMON / VARIE / dumpo, CONTR, merror
1361 SAVE / VARIE /
1362
1363 C
1364 DO I = 1,11
1365 DO J = 1,96
1366 if (j.le.6) basse(i,j) = 0.
1367 DEDX(I,J) = 0.
1368 ENDDO
1369 ENDDO
1370 C
1371 i = inf
1372 c
1373 10 continue
1374 if (i.gt.sup.or.i.gt.120000) then
1375 RETURN
1376 endif
1377 C
1378 40 format(2x,i5,2x,'status :',1x,Z4)
1379 C
1380 c
1381 st1 = 0
1382 do bit=0, 7
1383 bi = ibits(vect(i),bit+8,1)
1384 if (bi.eq.1) st1 = ibset(st1,bit)
1385 enddo
1386 43 format(2x,'vect(i) = ',Z8)
1387 if (st1.eq.8) then
1388 ib = 1
1389 else
1390 if (st1.eq.16) then
1391 ib = 0
1392 else
1393 if (iev.eq.dumpo) then
1394 print *,'i ',i
1395 write(*,43)vect(i)
1396 endif
1397 merror(contr) = 139
1398 if ( cer.eq.0 ) then
1399 RETURN
1400 else
1401 i = i + 1
1402 goto 10
1403 endif
1404 endif
1405 endif
1406 C
1407 if (ib.eq.1) then
1408 C
1409 st = IAND(vect(i),'00FF'x)
1410 c
1411 ipl = int(st/6) + 1
1412 ipr = st - (ipl - 1) * 6 + 1
1413 i = i + 1
1414 if (i.gt.sup.or.i.gt.120000) RETURN
1415 if ( ipl.ge.1.and.ipl.le.11.and.ipr.ge.1.and.ipr.le.6)
1416 + basse(ipl,ipr) = vect(i)
1417 c
1418 20 continue
1419 if (i.gt.sup.or.i.gt.120000) RETURN
1420 C
1421 i = i + 1
1422 if (i.gt.sup.or.i.gt.120000) RETURN
1423 if ((vect(i)+1).gt.16.or.(vect(i)+1).lt.1) then
1424 goto 10
1425 endif
1426 ist = vect(i) + 1 + 16 * (ipr - 1)
1427 i = i + 1
1428 if (i.gt.sup.or.i.gt.120000) RETURN
1429 if ( ipl.ge.1.and.ipl.le.11.and.ist.ge.1.and.ist.le.96)
1430 + dedx(ipl,ist) = vect(i)
1431 goto 20
1432 else
1433 C
1434 st = IAND(vect(i),'00FF'x)
1435 ipl = int(st/6) + 1
1436 ipr = st - (ipl - 1) * 6 + 1
1437 if ( ipl.ge.1.and.ipl.le.11 ) then
1438 do j = 1,16
1439 i = i + 1
1440 if (i.gt.sup.or.i.gt.120000) RETURN
1441 ist = j + 16 * (ipr - 1)
1442 if (ist.ge.1.and.ist.le.96) dedx(ipl,ist) = vect(i)
1443 enddo
1444 endif
1445 i = i + 1
1446 if (i.gt.sup.or.i.gt.120000) RETURN
1447 goto 10
1448 C
1449 endif
1450
1451
1452 RETURN
1453 END
1454
1455
1456 C----------------------------------------------------------
1457 SUBROUTINE CALFULL(vect,inf,sup,dedx,dedxc,basse,cer)
1458 C--------------------------------------------------------------
1459
1460 IMPLICIT NONE
1461
1462 INTEGER NPLA, NCHA, LENSEV
1463 PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1464 C
1465 INTEGER*2 VECT(30000)
1466 INTEGER inf, sup
1467 INTEGER i,j,k, iev, cer
1468 INTEGER contr
1469 integer stwerr(4),dumpo,merror(4)
1470 C
1471 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1472 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1473 & calDSPtaberr(4), calevnum(4)
1474 REAL dedx(11,96), basse(11,6), dedxc(11,96)
1475 real perror(4)
1476 C
1477 COMMON / evento / iev, stwerr,perror,
1478 & dexy,dexyc,base,
1479 & calselftrig,calIItrig,
1480 & calstriphit,calDSPtaberr,calevnum
1481
1482 save / evento /
1483 c
1484 COMMON / VARIE / dumpo, CONTR, merror
1485 SAVE / VARIE /
1486 C
1487 k = inf
1488 do i = 1,11
1489 do j = 1,96
1490 DEDX(I,J) = 0.
1491 if ( k.le.120000 ) dedx(i,j) = vect(k)
1492 k = k + 1
1493 enddo
1494 enddo
1495 C
1496 call CALCOMPRESS(vect,k,sup,dedxc,basse,cer)
1497 C
1498 10 FORMAT(2X,'Status word:',2X,Z8)
1499
1500 RETURN
1501 END
1502
1503
1504 C------------------------------------------------
1505 SUBROUTINE COUNTER(ve,er)
1506 C------------------------------------------------
1507
1508 IMPLICIT NONE
1509
1510 INTEGER NPLA, NCHA, LENSEV
1511 PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1512 C
1513 INTEGER*2 VE, st4
1514 INTEGER er, bit, bi, iev
1515 INTEGER contr
1516 integer stwerr(4),dumpo, merror(4)
1517 C
1518 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1519 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1520 & calDSPtaberr(4), calevnum(4)
1521 real perror(4)
1522 C
1523 COMMON / evento / IEV, stwerr,perror,
1524 & dexy,dexyc,base,
1525 & calselftrig,calIItrig,
1526 & calstriphit,calDSPtaberr,calevnum
1527
1528 save / evento /
1529
1530 COMMON / VARIE / dumpo, CONTR, merror
1531 SAVE / VARIE /
1532
1533
1534 st4 = 0
1535 st4 = IAND(ve,'00FF'x)
1536 if (st4.ne.0) then
1537 do bit=0, 6
1538 bi = ibits(st4,bit,1)
1539 if (bi.ne.0) then
1540 er = er + 2
1541 endif
1542 enddo
1543 endif
1544
1545 10 FORMAT(2X,'Status word:',2X,Z4)
1546 return
1547 end
1548
1549
1550 C------------------------------------------------
1551 SUBROUTINE MINERR(ic,icsave,chi,min,co)
1552 C------------------------------------------------
1553
1554 IMPLICIT NONE
1555 C
1556 INTEGER NPLA, NCHA, LENSEV
1557 PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1558 C
1559 INTEGER ic, icsave(1000), chi(1000)
1560 integer l, st, min,co
1561 INTEGER iev
1562 INTEGER contr
1563 integer stwerr(4),dumpo, merror(4)
1564 C
1565 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1566 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1567 & calDSPtaberr(4), calevnum(4)
1568 real perror(4)
1569 C
1570 COMMON / evento / iev, stwerr,perror,
1571 & dexy,dexyc,base,
1572 & calselftrig,calIItrig,
1573 & calstriphit,calDSPtaberr,calevnum
1574
1575 save / evento /
1576 C
1577 COMMON / VARIE / dumpo, CONTR, merror
1578 SAVE / VARIE /
1579
1580 st = chi(1)
1581 min = 1
1582 if (co.gt.1) then
1583 do l = 2, co
1584 if (chi(l).lt.st) then
1585 st = chi(l)
1586 min = l
1587 endif
1588 enddo
1589 endif
1590 ic = icsave(min)
1591
1592 return
1593 end
1594
1595 C-----------------------------------------------------
1596 SUBROUTINE CLEARSEC
1597 C-----------------------------------------------------
1598
1599 IMPLICIT NONE
1600 C
1601 INTEGER NPLA, NCHA, LENSEV
1602 PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1603 C
1604 INTEGER iev
1605 INTEGER contr, i,j
1606 integer stwerr(4),dumpo, merror(4)
1607 C
1608 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1609 real calselftrig(4,7), calIItrig(4), calstriphit(4),
1610 & calDSPtaberr(4), calevnum(4)
1611 real perror(4)
1612 C
1613 COMMON / evento / iev, stwerr,perror,
1614 & dexy,dexyc,base,
1615 & calselftrig,calIItrig,
1616 & calstriphit,calDSPtaberr,calevnum
1617
1618 save / evento /
1619 c
1620 COMMON / VARIE / dumpo, CONTR, merror
1621 SAVE / VARIE /
1622 C
1623 DO I = 1,11
1624 DO J = 1,96
1625 if (contr.eq.3) then
1626 DEXY(1,2*I,J) = 0.
1627 DEXYC(1,2*I,J) = 0.
1628 endif
1629 if (contr.eq.4) then
1630 DEXY(1,2*I-1,J) = 0.
1631 DEXYC(1,2*I-1,J) = 0.
1632 endif
1633 if (contr.eq.1) then
1634 DEXY(2,2*I-1,J) = 0.
1635 DEXYC(2,2*I-1,J) = 0.
1636 endif
1637 if (contr.eq.2) then
1638 DEXY(2,2*I,97-J) = 0.
1639 DEXYC(2,2*I,97-J) = 0.
1640 endif
1641 enddo
1642 do j = 1,6
1643 if (contr.eq.1) base(2,2*i-1,7-j) = 0.
1644 if (contr.eq.4) base(1,2*i-1,j) = 0.
1645 if (contr.eq.2) base(2,2*i,j) = 0.
1646 if (contr.eq.3) base(1,2*i,j) = 0.
1647 enddo
1648 if (i.le.7) calselftrig(contr,i) = 0.
1649 enddo
1650 calIItrig(contr) = 0.
1651 calstriphit(contr) = 0.
1652 calDSPtaberr(contr) = 0.
1653 calevnum(contr) = 0.
1654 return
1655 end
1656 C

  ViewVC Help
Powered by ViewVC 1.1.23