/[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.4 - (show annotations) (download)
Tue Dec 30 14:21:19 2008 UTC (16 years, 2 months ago) by mocchiut
Branch: MAIN
CVS Tags: v1r02, v1r00, v1r01
Changes since 1.3: +22 -10 lines
calunpack bug fixed, forgotten special file in the db added

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 PARAMETER (ival='FFFF'x)
127 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 integer scrcerr, sic, sicb
149 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 c dumpo = iev
176 start = 320
177 firsttime = 1
178 SOGLIA0 = 70
179 sic = 0
180 sicb = 0
181 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 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 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 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 ke = 0
311 chis = chi
312 icold = ic
313 DO i = 1, 120000
314 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 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 C clear vectors of that section in the common
830 C
831 call clearsec
832 C
833 calselftrig(k,1) = check
834 calselftrig(k,2) = vect(length)
835 c
836 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 & print *,' A crc is wrong ',ic,
851 & ' search section ',contr,' coco = ',coco
852 goto 32
853 else
854 c
855 c set some variables and try to go on
856 c
857 merror(contr) = 132
858 scrcerr = 1
859 sic = ic
860 sicb = icb
861
862 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 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 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 if ( scrcerr.eq.0 ) then
902 lleng = 0
903 goto 150
904 endif
905 endif
906 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 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 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 C FIRST CALORIMETER SIGNATURE: CA50
957 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 C SECOND CALORIMETER SIGNATURE: CA50
966 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 C test is here!
975 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 endif
992 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 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 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 C FIRST CALORIMETER SIGNATURE: CA50
1042 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 C SECOND CALORIMETER SIGNATURE: CA50
1051 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 C test is here!
1060 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 endif
1068 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 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 C
1123 150 continue
1124 C
1125 contr = contr + 1
1126
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 & print *,' B crc is wrong ',sic,
1142 & ' search section ',contr,' coco = ',coco
1143 goto 32
1144 c
1145 endif
1146
1147 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 c do l=1,lung
1269 c write(*,17)l,vecta(l)
1270 c enddo
1271 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 if ( k.le.120000 ) dedx(i,j) = vect(k)
1313 k = k + 1
1314 enddo
1315 enddo
1316 c
1317 RETURN
1318 END
1319
1320 C------------------------------------------------
1321 SUBROUTINE CALCOMPRESS(vect,inf,sup,dedx,basse,cer)
1322 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 integer bit,bi,cer
1339 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 if (i.gt.sup.or.i.gt.120000) then
1368 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 if ( cer.eq.0 ) then
1392 RETURN
1393 else
1394 i = i + 1
1395 goto 10
1396 endif
1397 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 if (i.gt.sup.or.i.gt.120000) RETURN
1408 if ( ipl.ge.1.and.ipl.le.11.and.ipr.ge.1.and.ipr.le.6)
1409 + basse(ipl,ipr) = vect(i)
1410 c
1411 20 continue
1412 if (i.gt.sup.or.i.gt.120000) RETURN
1413 C
1414 i = i + 1
1415 if (i.gt.sup.or.i.gt.120000) RETURN
1416 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 if (i.gt.sup.or.i.gt.120000) RETURN
1422 if ( ipl.ge.1.and.ipl.le.11.and.ist.ge.1.and.ist.le.96)
1423 + dedx(ipl,ist) = vect(i)
1424 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 if ( ipl.ge.1.and.ipl.le.11 ) then
1431 do j = 1,16
1432 i = i + 1
1433 if (i.gt.sup.or.i.gt.120000) RETURN
1434 ist = j + 16 * (ipr - 1)
1435 if (ist.ge.1.and.ist.le.96) dedx(ipl,ist) = vect(i)
1436 enddo
1437 endif
1438 i = i + 1
1439 if (i.gt.sup.or.i.gt.120000) RETURN
1440 goto 10
1441 C
1442 endif
1443
1444
1445 RETURN
1446 END
1447
1448
1449 C----------------------------------------------------------
1450 SUBROUTINE CALFULL(vect,inf,sup,dedx,dedxc,basse,cer)
1451 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 INTEGER i,j,k, iev, cer
1461 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 if ( k.le.120000 ) dedx(i,j) = vect(k)
1485 k = k + 1
1486 enddo
1487 enddo
1488 C
1489 call CALCOMPRESS(vect,k,sup,dedxc,basse,cer)
1490 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