/[PAMELA software]/yoda/techmodel/forroutines/calorimeter/calunpack.for
ViewVC logotype

Annotation of /yoda/techmodel/forroutines/calorimeter/calunpack.for

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.9 - (hide annotations) (download)
Fri Aug 20 15:01:46 2004 UTC (20 years, 3 months ago) by kusanagi
Branch: MAIN
Changes since 1.8: +59 -30 lines 
*** empty log message ***
1 kusanagi 1.8 C
2     C Written by Mirko Boezio and Emiliano Mocchiutti
3     C
4 kusanagi 1.9 C * Version: 2.18.0 *
5     C
6     C Changelog:
7 kusanagi 1.8 C
8 kusanagi 1.9 C 2.17 - 2.18.0: corrected bug which made unable the program to find CRC
9     C errors in the last section of the calorimeter;
10     C added a "debugging" option to dump to standard output
11     C the whole packet in hexadecimal format and other
12     C useful informations. To activate it the dump variable
13     C in the common varie must be passed with the value
14     C of iev you want to check. Do nothing if you don't want
15     C any output.
16     C
17 kusanagi 1.3 C------------------------------------------------
18 kusanagi 1.7 SUBROUTINE CALUNPACK(vecta,lung,me)
19 kusanagi 1.3 C------------------------------------------------
20    
21     IMPLICIT NONE
22     C
23     C Normal variables definition
24     C
25 kusanagi 1.8 INTEGER SOGLIA, SOGLIA0, START
26     PARAMETER (SOGLIA0=7)
27 kusanagi 1.3 PARAMETER (SOGLIA=27)
28 kusanagi 1.8 PARAMETER (START=80)
29 kusanagi 1.9 integer lung, me, pro, m, dump
30 kusanagi 1.3 c
31     INTEGER NPLA, NCHA, LENSEV
32     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
33 kusanagi 1.7
34 kusanagi 1.3 INTEGER merror(4)
35     C
36 kusanagi 1.8 INTEGER i, j, iev, min, st2c, bit, bi, lleng, salta
37 kusanagi 1.3 C
38 kusanagi 1.7 INTEGER*1 VECTA(lung)
39 kusanagi 1.9 INTEGER*2 vect(60000), test
40 kusanagi 1.3 C
41 kusanagi 1.6 integer*2 check, crc, e2(4)
42 kusanagi 1.3 C
43     INTEGER ic, k,l, ke, ic0, icsave(1000), chi(1000)
44     INTEGER status, contr, cstatus, co, nta, conte
45 kusanagi 1.5 INTEGER inf, sup, em, esci, icb
46 kusanagi 1.6 INTEGER XO, YO, XE, YE,iev2
47 kusanagi 1.3
48     INTEGER*2 length, length2
49    
50 kusanagi 1.5 INTEGER*2 st1, st2, cst1, st4
51    
52 kusanagi 1.7 integer st1b, st2b,p, lunga, pari
53 kusanagi 1.3
54     INTEGER*2 ival
55     PARAMETER (ival='FFFF'x)
56    
57     real dedx1(11,96),dedx2(11,96),dedx3(11,96),dedx4(11,96)
58     real dedx1c(11,96),dedx2c(11,96),dedx3c(11,96),dedx4c(11,96)
59     real base1(11,6),base2(11,6),base3(11,6),base4(11,6)
60 kusanagi 1.6 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
61 kusanagi 1.3
62    
63     real auto(7)
64     real calselftrig(4,7), calIItrig(4), calstripshit(4),
65     & calDSPtaberr(4), calevnum(4)
66    
67     DATA XO/241/ ! CODE_EV_R XO = 111 10001
68     DATA YO/237/ ! CODE_EV_R YO = 111 01101
69     DATA XE/234/ ! CODE_EV_R XE = 111 01010
70     DATA YE/246/ ! CODE_EV_R YE = 111 10110
71    
72     REAL calped(4,11,96), calgood(4,11,96), calthr(4,11,6)
73     REAL calrms(4,11,96), calbase(4,11,6), calvar(4,11,6)
74     REAL calpuls(4,11,96)
75 kusanagi 1.8 real perror(4)
76     integer stwerr(4)
77 kusanagi 1.3
78 kusanagi 1.8 COMMON / evento / IEV, stwerr, perror,
79 kusanagi 1.3 & dexy,dexyc,base,
80     & calselftrig,calIItrig,
81     & calstripshit,calDSPtaberr,calevnum
82    
83     save / evento /
84    
85     COMMON / calib / IEV2, calped, calgood, calthr, calrms,
86     & calbase,
87     & calvar,
88     & calpuls
89    
90     save / calib /
91    
92     c
93 kusanagi 1.9 COMMON / VARIE / merror, CONTR, e2, dump
94 kusanagi 1.3 SAVE / VARIE /
95    
96     C
97     C Begin !
98     C
99 kusanagi 1.9 if (dump.eq.0) dump=-1
100     if (iev.eq.dump) then
101     c do l=1,lung,2
102     c write(*,18)l,vecta(l),vecta(l+1)
103     c enddo
104     do l=1,lung
105     write(*,17)l,vecta(l)
106     enddo
107     endif
108     c
109 kusanagi 1.8 if (iev.lt.0.or.iev.gt.9000000) iev = 0
110 kusanagi 1.5 min = 0
111 kusanagi 1.7 lleng = 0
112 kusanagi 1.8 salta = 0
113 kusanagi 1.5 m = 0
114 kusanagi 1.7 pari = 0
115     IF (MOD(LUNG,2).EQ.0) THEN
116     lunga = lung / 2
117     pari = 1
118     else
119     lunga = int(lung/2) + 1
120     endif
121     c
122 kusanagi 1.9 if (lunga.gt.60000.and.dump.gt.0) then
123     print *,'Calorimeter WARNING: more than 60000 words!'
124     lunga = 60000
125 kusanagi 1.6 endif
126 kusanagi 1.5 c
127 kusanagi 1.7 call canctutto
128 kusanagi 1.6 call azero(dedx1,11*96)
129     call azero(dedx2,11*96)
130     call azero(dedx3,11*96)
131     call azero(dedx4,11*96)
132     call azero(dedx1c,11*96)
133     call azero(dedx2c,11*96)
134     call azero(dedx3c,11*96)
135     call azero(dedx4c,11*96)
136     call azero(base1,11*6)
137     call azero(base2,11*6)
138     call azero(base3,11*6)
139     call azero(base4,11*6)
140     C
141 kusanagi 1.5 do l = 1,4
142 kusanagi 1.8 perror(l) = 0.
143     stwerr(l) = 0
144 kusanagi 1.5 e2(l) = 0
145     merror(l) = 0
146     enddo
147     c
148 kusanagi 1.3 do l = 1,1000
149     icsave(l) = 0
150     chi(l) = 0
151     enddo
152     em = 0
153     co = 0
154     esci = 0
155     me = 1
156     c
157     contr = 1
158     c
159 kusanagi 1.8 ic = 1
160 kusanagi 1.5 icb = 0
161 kusanagi 1.3 nta = 0
162     c
163 kusanagi 1.8 CX length2 = ic - 2
164     length2 = start
165 kusanagi 1.3 c
166     20 continue
167     nta = nta + 1
168 kusanagi 1.6 c
169 kusanagi 1.5 if (length2.ge.-2) then
170     ic = ic + (2 * (length2 + 2))
171     else
172 kusanagi 1.9 if (dump.gt.0)
173     & print *,'Calorimeter WARNING: length errors ',ic,length2,nta
174 kusanagi 1.5 endif
175     c
176     32 continue
177     c
178 kusanagi 1.3 ke = 0
179     do while (ke.eq.0)
180     C
181     C Check consistency of header.
182     C it is composed by CODE+D# (8 bits) and by SATUS WORD (8 bits)
183     c so we must split vect into the two components:
184     C
185     C ST1 is CODE + D#
186 kusanagi 1.6 c
187 kusanagi 1.5 st1b = 0
188     st2b = 0
189 kusanagi 1.7 if ((ic+3).gt.lung) then
190     if (co.eq.0) co = 1
191     chi(co) = chi(co) + 8 * (5 - contr)
192     merror(contr) = 130
193     if (contr.ne.1) contr=5
194     goto 200
195     endif
196 kusanagi 1.5 do bit = 0, 7
197     bi = ibits(vecta(ic),bit,1)
198     if (bi.eq.1) st1b = ibset(st1b,bit)
199     bi = ibits(vecta(ic+1),bit,1)
200     if (bi.eq.1) st2b = ibset(st2b,bit)
201     enddo
202 kusanagi 1.6 c
203 kusanagi 1.3 C ST2 is the STATUS WORD
204 kusanagi 1.6 c
205 kusanagi 1.5 length2 = 0
206     do bit=0, 7
207     bi = ibits(vecta(ic+3),bit,1)
208     if (bi.eq.1) length2 = ibset(length2,bit)
209     bi = ibits(vecta(ic+2),bit,1)
210     if (bi.eq.1) length2 = ibset(length2,bit+8)
211     enddo
212 kusanagi 1.3 c the crc should be at vect(length) with
213 kusanagi 1.5 length = length2 + 1
214 kusanagi 1.3 C
215     c some checks to be sure we have found the calorimeter data:
216     c
217     c status word is always less then 129
218     c
219 kusanagi 1.5 if (st2b.gt.128) then
220     length = 0
221     goto 100
222     endif
223 kusanagi 1.3 c
224     c length of the packet must be less then 20000 if no errors
225     c are found
226     c
227 kusanagi 1.7 if (st2b.eq.0.and.length2.gt.lunga) then
228 kusanagi 1.5 length = 0
229     goto 100
230     endif
231 kusanagi 1.3 c
232 kusanagi 1.6 if (length2.le.0) then
233 kusanagi 1.5 length = 0
234     goto 100
235     endif
236     c
237 kusanagi 1.3 e2(contr) = 0
238     C
239     if (contr.eq.1) then
240     c
241     c is it the first section?
242     c
243 kusanagi 1.5 if (st1b.eq.YE) then
244 kusanagi 1.3 c if so go out of this loop and go on recording data
245     ke = 1
246     if (em.eq.0) then
247     em = 1
248     co = co + 1
249     icsave(co) = ic
250     endif
251 kusanagi 1.5 m = ic
252 kusanagi 1.7 call riempi(m,lunga,lleng,lung,pari,vect,vecta)
253 kusanagi 1.5 icb = 1
254     if (st2b.ne.0) then
255     E2(contr) = vect(icb)
256 kusanagi 1.3 call contaer(e2(contr),chi(co))
257     endif
258     else
259     c if not, is it one of the next sections? did we miss a section?
260 kusanagi 1.5 if (st1b.eq.YO.or.st1b.eq.XE.or.st1b.eq.XO) THEN
261 kusanagi 1.3 c if so, record an error and go back analizing this section
262     merror(contr) = 129
263     contr = 2
264     if (em.eq.0) then
265     em = 1
266     co = co + 1
267     icsave(co) = ic
268     endif
269     chi(co) = chi(co) + 8
270 kusanagi 1.5 goto 32
271 kusanagi 1.3 ELSE
272     c if it is not the case, go on with the next value of vect
273     GOTO 100
274     endif
275     endif
276     ENDIF
277     C
278     c the same for the second section, ...
279     c
280     if (CONTR.eq.2) then
281 kusanagi 1.5 if (st1b.eq.YO) then
282 kusanagi 1.3 ke = 1
283     if (em.eq.0) then
284     em = 1
285     co = co + 1
286     icsave(co) = ic
287     endif
288 kusanagi 1.5 m = ic
289 kusanagi 1.7 call riempi(m,lunga,lleng,lung,pari,vect,vecta)
290 kusanagi 1.5 icb = 1
291     if (st2b.ne.0) then
292     E2(contr) = vect(icb)
293 kusanagi 1.3 call contaer(e2(contr),chi(co))
294     endif
295 kusanagi 1.5 goto 9
296 kusanagi 1.3 else
297 kusanagi 1.5 if (st1b.eq.XE.or.st1b.eq.XO) then
298 kusanagi 1.3 merror(contr) = 129
299     contr = 3
300     if (em.eq.0) then
301     em = 1
302     co = co + 1
303     icsave(co) = ic
304     endif
305     chi(co) = chi(co) + 8
306 kusanagi 1.5 goto 32
307 kusanagi 1.3 ELSE
308     GOTO 100
309     endif
310     endif
311     ENDIF
312     c
313     C ... for the third,...
314     c
315     if (CONTR.eq.3) then
316 kusanagi 1.5 if (st1b.eq.XE) then
317 kusanagi 1.3 ke = 1
318     if (em.eq.0) then
319     em = 1
320     co = co + 1
321     icsave(co) = ic
322     endif
323 kusanagi 1.5 m = ic
324 kusanagi 1.7 call riempi(m,lunga,lleng,lung,pari,vect,vecta)
325 kusanagi 1.5 icb = 1
326     if (st2b.ne.0) then
327     E2(contr) = vect(icb)
328 kusanagi 1.3 call contaer(e2(contr),chi(co))
329     endif
330 kusanagi 1.5 goto 9
331 kusanagi 1.3 else
332 kusanagi 1.5 if (st1b.eq.XO) then
333 kusanagi 1.3 merror(contr) = 129
334     contr = 4
335     if (em.eq.0) then
336     em = 1
337     co = co + 1
338     icsave(co) = ic
339     endif
340     chi(co) = chi(co) + 8
341 kusanagi 1.5 goto 32
342 kusanagi 1.3 ELSE
343     GOTO 100
344     endif
345     endif
346     ENDIF
347     C
348     c ...and for the last section.
349     c
350     if (CONTR.eq.4) then
351 kusanagi 1.5 if (st1b.eq.XO) then
352 kusanagi 1.3 ke = 1
353     if (em.eq.0) then
354     em = 1
355     co = co + 1
356     icsave(co) = ic
357     endif
358 kusanagi 1.5 m = ic
359 kusanagi 1.7 call riempi(m,lunga,lleng,lung,pari,vect,vecta)
360 kusanagi 1.5 icb = 1
361     if (st2b.ne.0) then
362     E2(contr) = vect(icb)
363 kusanagi 1.3 call contaer(e2(contr),chi(co))
364     endif
365     else
366 kusanagi 1.6 c we should never arrive here (in case we run out of vector if section
367     c four is missing!)... however here it is in case of bugs!
368     c
369 kusanagi 1.5 goto 100
370 kusanagi 1.3 endif
371     endif
372     C
373     100 CONTINUE
374     c
375     c increment vector of one searching for the next section
376     c
377 kusanagi 1.5 9 continue
378 kusanagi 1.3 ic = ic + 1
379     c
380     c if we run out of vector give an error and exit the subroutine
381     c
382 kusanagi 1.7 if (ic.gt.(lung-1)) then
383 kusanagi 1.5 if (co.eq.0) co = 1
384 kusanagi 1.3 chi(co) = chi(co) + 8 * (5 - contr)
385     merror(contr) = 130
386     if (contr.ne.1) contr=5
387     goto 200
388     endif
389     enddo
390     C
391     c format not used
392     c
393 kusanagi 1.7 10 FORMAT(2X,'Error for view:',2X,I1,2X,'Status word:',2X,Z4)
394     11 FORMAT(2X,'View or command not recognized for view:',2X,I1,2X,
395     & 'Status word:',2X,Z4)
396     12 FORMAT(2X,'Error - did NOT find view:',2X,I1)
397     13 FORMAT(2X,'Error - eof reached, exiting')
398     14 FORMAT(2X,I8,2X,I10)
399     15 FORMAT(2X,I8,2X,Z8)
400 kusanagi 1.9 17 FORMAT(2X,'Elemento:',2X,I6,2X,' word:',2X,Z8)
401     18 FORMAT(2X,'Elemento:',2X,I6,2X,' word:',2X,Z2,Z2)
402     21 FORMAT(2X,'CRC: ',2X,Z8)
403     C
404 kusanagi 1.3 c go on recording data
405 kusanagi 1.7 ic = ic - 1
406     c
407     K = CONTR
408     ic0 = icb
409     icb = icb + 1
410     length = vect(icb) + 2
411     length2 = vect(icb)
412 kusanagi 1.8 lleng = (length*2) - 1
413 kusanagi 1.3 C
414     C Check consistency of CRC.
415     C
416 kusanagi 1.7 check = 0.
417     inf = ic0
418     sup = length - 1
419     do i = inf,sup
420     check=crc(check,vect(i))
421     enddo
422 kusanagi 1.9
423     if (iev.eq.dump) write(*,21)vect(length)
424     if (iev.eq.dump) write(*,21)check
425 kusanagi 1.6 c
426 kusanagi 1.7 if (check.ne.vect(length)) then
427     merror(contr) = 132
428     chi(co) = chi(co) + 4
429     lleng = 0
430 kusanagi 1.8 if (length2.lt.lunga.and.length2.gt.0) then
431 kusanagi 1.9 c goto 19
432     goto 150
433 kusanagi 1.8 else
434     contr = contr + 1
435     c ic = ic + 1
436     goto 32
437     endif
438 kusanagi 1.7 endif
439 kusanagi 1.5 C
440 kusanagi 1.3 C Process data.
441     C
442 kusanagi 1.8 19 CONTINUE
443 kusanagi 1.7 if (esci.eq.1) then
444     c
445 kusanagi 1.5 do i = 1, 7
446     icb = icb + 1
447     auto(i) = vect(icb)
448 kusanagi 1.3 enddo
449 kusanagi 1.7 C
450 kusanagi 1.5 if (st2b.ne.0) then
451     do bit=0, 6
452     bi = ibits(st2b,bit,1)
453     if (bit.eq.3.and.bi.ne.0) st2c = 8
454     enddo
455     endif
456 kusanagi 1.7 C
457 kusanagi 1.5 if (st2c.eq.8) then
458 kusanagi 1.3 if (length2.ne.1064) then
459     merror(contr) = 133
460     chi(co) = chi(co) + 4
461 kusanagi 1.7 lleng = 0
462 kusanagi 1.3 goto 150
463 kusanagi 1.5 else
464 kusanagi 1.6 if (k.eq.1) then
465     call azero(dedx1,11*96)
466     call azero(dedx2,11*96)
467     call azero(dedx3,11*96)
468     call azero(dedx4,11*96)
469     call azero(dedx1c,11*96)
470     call azero(dedx2c,11*96)
471     call azero(dedx3c,11*96)
472     call azero(dedx4c,11*96)
473     call azero(base1,11*6)
474     call azero(base2,11*6)
475     call azero(base3,11*6)
476     call azero(base4,11*6)
477     call CALRAW(vect,icb+1,length-1,dedx1)
478     endif
479 kusanagi 1.5 if (k.eq.2) call CALRAW(vect,icb+1,length-1,dedx2)
480     if (k.eq.3) call CALRAW(vect,icb+1,length-1,dedx3)
481     if (k.eq.4) call CALRAW(vect,icb+1,length-1,dedx4)
482 kusanagi 1.3 endif
483 kusanagi 1.5 goto 50
484 kusanagi 1.3 endif
485 kusanagi 1.7 C
486 kusanagi 1.3 41 FORMAT(2X,I2,2X,'word :',1x,z4)
487 kusanagi 1.5 test = vect(icb+3)
488 kusanagi 1.7 c
489 kusanagi 1.5 if (test.eq.ival) then
490 kusanagi 1.3 if (length2.gt.1201) then
491     merror(contr) = 134
492     chi(co) = chi(co) + 4
493 kusanagi 1.7 lleng = 0
494 kusanagi 1.3 goto 150
495     else
496 kusanagi 1.5 icb = icb + 1
497     calIItrig(k) = vect(icb)
498     icb = icb + 1
499     calstripshit(k) = vect(icb)
500     icb = icb + 1
501     C qui c'e` test!
502     icb = icb + 1
503     calDSPtaberr(k) = vect(icb)
504     icb = icb + 1
505     calevnum(k) = vect(icb)
506     merror(contr) = 137
507 kusanagi 1.6 if (k.eq.1) then
508     call azero(dedx1,11*96)
509     call azero(dedx2,11*96)
510     call azero(dedx3,11*96)
511     call azero(dedx4,11*96)
512     call azero(dedx1c,11*96)
513     call azero(dedx2c,11*96)
514     call azero(dedx3c,11*96)
515     call azero(dedx4c,11*96)
516     call azero(base1,11*6)
517     call azero(base2,11*6)
518     call azero(base3,11*6)
519     call azero(base4,11*6)
520     call CALCOMPRESS(vect,icb+1,length-1,dedx1c,
521     & base1)
522     endif
523     if (k.eq.2) call CALCOMPRESS(vect,icb+1,length-1,dedx2c,
524 kusanagi 1.3 & base2)
525 kusanagi 1.6 if (k.eq.3) call CALCOMPRESS(vect,icb+1,length-1,dedx3c,
526 kusanagi 1.3 & base3)
527 kusanagi 1.6 if (k.eq.4) call CALCOMPRESS(vect,icb+1,length-1,dedx4c,
528 kusanagi 1.3 & base4)
529 kusanagi 1.5 goto 50
530 kusanagi 1.3 endif
531 kusanagi 1.5 else if (test.eq.0) then
532 kusanagi 1.3 if (length2.gt.2257) then
533     merror(contr) = 135
534     chi(co) = chi(co) + 4
535 kusanagi 1.7 lleng = 0
536 kusanagi 1.3 goto 150
537     else
538 kusanagi 1.5 icb = icb + 1
539     calIItrig(k) = vect(icb)
540     icb = icb + 1
541     calstripshit(k) = vect(icb)
542     icb = icb + 1
543 kusanagi 1.7 C qui c'e` test
544 kusanagi 1.5 icb = icb + 1
545     calDSPtaberr(k) = vect(icb)
546     icb = icb + 1
547     calevnum(k) = vect(icb)
548     merror(contr) = 138
549 kusanagi 1.6 if (k.eq.1) then
550     call azero(dedx1,11*96)
551     call azero(dedx2,11*96)
552     call azero(dedx3,11*96)
553     call azero(dedx4,11*96)
554     call azero(dedx1c,11*96)
555     call azero(dedx2c,11*96)
556     call azero(dedx3c,11*96)
557     call azero(dedx4c,11*96)
558     call azero(base1,11*6)
559     call azero(base2,11*6)
560     call azero(base3,11*6)
561     call azero(base4,11*6)
562     call CALFULL(vect,icb+1,length-1,dedx1,
563     & dedx1c,base1)
564     endif
565 kusanagi 1.5 if (k.eq.2) call CALFULL(vect,icb+1,length-1,dedx2,
566 kusanagi 1.3 & dedx2c,base2)
567 kusanagi 1.5 if (k.eq.3) call CALFULL(vect,icb+1,length-1,dedx3,
568 kusanagi 1.3 & dedx3c,base3)
569 kusanagi 1.5 if (k.eq.4) call CALFULL(vect,icb+1,length-1,dedx4,
570 kusanagi 1.3 & dedx4c,base4)
571 kusanagi 1.5 goto 50
572 kusanagi 1.3 endif
573     else
574     merror(contr) = 136
575     chi(co) = chi(co) + 4
576 kusanagi 1.7 lleng = 0
577 kusanagi 1.5 goto 150
578 kusanagi 1.3 endif
579 kusanagi 1.7 C
580 kusanagi 1.3 do i = 1,7
581     calselftrig(k,i) = auto(i)
582     enddo
583 kusanagi 1.7 c
584 kusanagi 1.3 50 continue
585     c
586 kusanagi 1.7 C
587     DO I = 1,11
588     DO J = 1,96
589     DEXY(2,2*I-1,97-J) = DEDX3(I,J)
590     DEXY(1,2*I-1,J) = DEDX2(I,J)
591     DEXY(2,2*I,J) = DEDX4(I,J)
592     DEXY(1,2*I,J) = DEDX1(I,J)
593     DEXYC(2,2*I-1,97-J) = DEDX3C(I,J)
594     DEXYC(1,2*I-1,J) = DEDX2C(I,J)
595     DEXYC(2,2*I,J) = DEDX4C(I,J)
596     DEXYC(1,2*I,J) = DEDX1C(I,J)
597     enddo
598     do j = 1,6
599     base(2,2*i-1,7-j) = base3(i,j)
600     base(1,2*i-1,j) = base2(i,j)
601     base(2,2*i,j) = base4(i,j)
602     base(1,2*i,j) = base1(i,j)
603     enddo
604 kusanagi 1.3 enddo
605 kusanagi 1.7 C
606     endif
607 kusanagi 1.3 C
608     150 continue
609     C
610     contr = contr + 1
611     C
612     c go on till we have found all the four sections
613     c
614 kusanagi 1.5 if (contr.lt.5) goto 20
615 kusanagi 1.3 c
616 kusanagi 1.8 200 continue
617     C
618 kusanagi 1.3 c
619 kusanagi 1.8 if (esci.eq.0.and.co.ge.1.and.icsave(co).le.lung) then
620     if (salta.eq.co) then
621     esci = 1
622     goto 201
623     else
624 kusanagi 1.9 c if (iev.eq.1) chi(co) = 0
625 kusanagi 1.8 if (chi(co).lt.soglia0) then
626     esci = 1
627     ic = icsave(co)
628     else
629 kusanagi 1.9 if (iev.eq.dump) print *,'chi(co) ',chi(co)
630     c
631 kusanagi 1.8 IF (salta.eq.0) then
632     ic = 1
633     length2 = - 2
634     salta = -1
635     else
636     ic = icsave(co) + 1
637     salta = co
638     endif
639     endif
640     em = 0
641     contr = 1
642     goto 32
643     endif
644     endif
645 kusanagi 1.3 c
646 kusanagi 1.8 if (co.eq.0.and.length2.eq.start) then
647     em = 0
648     contr = 1
649     ic = 1
650     length2 = -2
651     goto 20
652     endif
653    
654     c
655    
656     201 continue
657    
658 kusanagi 1.3 C
659     C if all section are missing clear vectors and go out
660     C
661     if (merror(1).eq.129.and.merror(2).eq.129
662     & .and.merror(3).eq.129.and.merror(4).eq.130) then
663     do l = 1,4
664     e2(l) = 0
665     merror(l) = 0
666     enddo
667 kusanagi 1.7 call canctutto
668 kusanagi 1.3 contr=1
669     if (esci.eq.0) then
670 kusanagi 1.5 ic = ic + 1
671     nta = nta +1
672 kusanagi 1.7 lleng = 0
673 kusanagi 1.5 goto 32
674     else
675     goto 999
676 kusanagi 1.3 endif
677     endif
678     c
679 kusanagi 1.8 if (esci.eq.1.and.salta.eq.co) then
680 kusanagi 1.3 min = 0
681     call minerr(ic,icsave,chi,min,co)
682 kusanagi 1.7 call canctutto
683 kusanagi 1.5 do l = 1,4
684     e2(l) = 0
685     merror(l) = 0
686     enddo
687 kusanagi 1.3 contr = 1
688     if (chi(min).lt.SOGLIA) then
689     me = 0
690 kusanagi 1.5 nta = nta + 1
691 kusanagi 1.7 lleng = 0
692 kusanagi 1.8 salta = -1
693 kusanagi 1.5 goto 32
694 kusanagi 1.3 else
695     do l = 1,4
696     e2(l) = 0
697     merror(l) = 0
698     enddo
699     me = 1
700     goto 999
701     endif
702     endif
703     c
704     if (esci.eq.0) then
705 kusanagi 1.7 call canctutto
706 kusanagi 1.5 length = 0
707 kusanagi 1.7 lleng = 0
708 kusanagi 1.5 ic = ic + 1
709     do l = 1,4
710     e2(l) = 0
711     merror(l) = 0
712     enddo
713     goto 32
714 kusanagi 1.3 endif
715     c
716     999 continue
717 kusanagi 1.8 do l = 1, 4
718     do bit=0, 31
719     if (bit.lt.16) then
720     bi = ibits(E2(L),bit,1)
721     else
722     bi = 0
723     endif
724     if (bi.eq.1) stwerr(l) = ibset(stwerr(l),bit)
725     enddo
726     perror(l) = float(merror(l))
727 kusanagi 1.7 enddo
728 kusanagi 1.8 c
729     iev = iev + 1
730 kusanagi 1.3 RETURN
731     END
732    
733    
734     C------------------------------------------------
735     SUBROUTINE CALRAW(vect,inf,sup,dedx)
736     C------------------------------------------------
737    
738     IMPLICIT NONE
739    
740 kusanagi 1.7 INTEGER*2 VECT(30000)
741 kusanagi 1.3 INTEGER inf, sup
742     INTEGER i,j,k, iev,iev2
743    
744     C
745     INTEGER NPLA, NCHA, LENSEV
746     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
747     INTEGER merror(4)
748     integer*2 e2(4)
749     INTEGER contr
750 kusanagi 1.6 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
751 kusanagi 1.3
752    
753     real calselftrig(4,7), calIItrig(4), calstripshit(4),
754     & calDSPtaberr(4), calevnum(4)
755    
756    
757     REAL calped(4,11,96), calgood(4,11,96), calthr(4,11,6)
758     REAL calrms(4,11,96), calbase(4,11,6), calvar(4,11,6)
759     REAL calpuls(4,11,96)
760     REAL dedx(11,96)
761 kusanagi 1.8 real perror(4)
762 kusanagi 1.9 integer stwerr(4), dump
763 kusanagi 1.3
764 kusanagi 1.8 COMMON / evento / IEV, stwerr, perror,
765 kusanagi 1.3 & dexy,dexyc,base,
766     & calselftrig,calIItrig,
767     & calstripshit,calDSPtaberr,calevnum
768    
769     save / evento /
770    
771     COMMON / calib / IEV2, calped, calgood, calthr, calrms,
772     & calbase,
773     & calvar,
774     & calpuls
775    
776     save / calib /
777     c
778 kusanagi 1.9 COMMON / VARIE / merror, CONTR, e2, dump
779 kusanagi 1.3 SAVE / VARIE /
780    
781     C
782     DO I = 1,11
783     DO J = 1,96
784     DEDX(I,J) = 0.
785     ENDDO
786     ENDDO
787     C
788     k = inf
789     do j = 1,96
790     do i = 1,11
791     dedx(i,j) = vect(k)
792     k = k + 1
793     enddo
794     enddo
795     c
796     RETURN
797     END
798    
799     C------------------------------------------------
800     SUBROUTINE CALCOMPRESS(vect,inf,sup,dedx,basse)
801     C------------------------------------------------
802    
803     IMPLICIT NONE
804    
805 kusanagi 1.7 INTEGER*2 VECT(30000) , st3
806 kusanagi 1.3 C
807     INTEGER inf, sup
808 kusanagi 1.6 INTEGER i,j, iev,iev2,h
809 kusanagi 1.3 INTEGER*2 st, st1, st2
810     C
811     INTEGER ib
812     INTEGER ipl, ipr, ist
813     C
814     C
815     INTEGER NPLA, NCHA, LENSEV
816     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
817     INTEGER merror(4)
818     integer*2 e2(4)
819     INTEGER contr
820 kusanagi 1.6 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
821 kusanagi 1.3
822    
823     real calselftrig(4,7), calIItrig(4), calstripshit(4),
824     & calDSPtaberr(4), calevnum(4)
825    
826    
827     REAL calped(4,11,96), calgood(4,11,96), calthr(4,11,6)
828     REAL calrms(4,11,96), calbase(4,11,6), calvar(4,11,6)
829     REAL calpuls(4,11,96)
830     REAL dedx(11,96), basse(11,6)
831 kusanagi 1.8 real perror(4)
832 kusanagi 1.9 integer stwerr(4),dump
833 kusanagi 1.3 C
834 kusanagi 1.8 COMMON / evento / IEV, stwerr,perror,
835 kusanagi 1.3 & dexy,dexyc,base,
836     & calselftrig,calIItrig,
837     & calstripshit,calDSPtaberr,calevnum
838    
839     save / evento /
840    
841     COMMON / calib / IEV2, calped, calgood, calthr, calrms,
842     & calbase,
843     & calvar,
844     & calpuls
845    
846     save / calib /
847     c
848 kusanagi 1.9 COMMON / VARIE / merror, CONTR, e2, dump
849 kusanagi 1.3 SAVE / VARIE /
850    
851     C
852     DO I = 1,11
853     DO J = 1,96
854     DEDX(I,J) = 0.
855     ENDDO
856     do j = 1,6
857     basse(i,j) = 0.
858     enddo
859     ENDDO
860     C
861 kusanagi 1.5 i = inf
862     c
863 kusanagi 1.3 10 continue
864 kusanagi 1.6 if (i.gt.sup) then
865     RETURN
866     endif
867 kusanagi 1.3 C
868     40 format(2x,i5,2x,'status :',1x,Z4)
869 kusanagi 1.5 C
870     c
871     st1 = 0
872 kusanagi 1.3 st1 = IAND(vect(i),'0800'x)
873     st1 = ISHFT(st1,-11)
874 kusanagi 1.6 cc 41 format(2x,'st1 = ',Z8)
875     cc 42 format(2x,'st2 = ',Z8)
876 kusanagi 1.9 43 format(2x,'vect(i) = ',Z8)
877 kusanagi 1.3 cc 44 format(2x,'vect(i) dopo = ',Z8)
878 kusanagi 1.6 cc 45 format(2x,'vect(i) ib = 1 : ',Z8)
879     cc 46 format(2x,'vect(i) < 0 : ',Z8)
880 kusanagi 1.3 if (st1.eq.1) then
881     ib = 1
882     else
883 kusanagi 1.6 st2 = IAND(vect(i),'1000'x)
884     st2 = ISHFT(st2,-12)
885     if (st2.eq.1) then
886 kusanagi 1.3 ib = 0
887     else
888 kusanagi 1.9 if (iev.eq.dump) then
889     print *,'i ',i
890     write(*,43)vect(i)
891     endif
892 kusanagi 1.5 merror(contr) = 139
893 kusanagi 1.3 RETURN
894     endif
895     endif
896     C
897     if (ib.eq.1) then
898 kusanagi 1.6 C
899 kusanagi 1.3 st = IAND(vect(i),'00FF'x)
900 kusanagi 1.5 c
901 kusanagi 1.3 ipl = int(st/6) + 1
902 kusanagi 1.5 ipr = st - (ipl - 1) * 6 + 1
903 kusanagi 1.3 i = i + 1
904 kusanagi 1.6 if (i.gt.sup) RETURN
905 kusanagi 1.3 basse(ipl,ipr) = vect(i)
906 kusanagi 1.6 c
907 kusanagi 1.3 20 continue
908     if (i.gt.sup) RETURN
909     C
910     i = i + 1
911 kusanagi 1.6 if (i.gt.sup) RETURN
912     if ((vect(i)+1).gt.16.or.(vect(i)+1).lt.1) then
913     goto 10
914     endif
915     ist = vect(i) + 1 + 16 * (ipr - 1)
916 kusanagi 1.3 i = i + 1
917 kusanagi 1.6 if (i.gt.sup) RETURN
918 kusanagi 1.5 dedx(ipl,ist) = vect(i)
919 kusanagi 1.6 goto 20
920 kusanagi 1.3 else
921     C
922     st = IAND(vect(i),'00FF'x)
923 kusanagi 1.6 ipl = int(st/6) + 1
924 kusanagi 1.5 ipr = st - (ipl - 1) * 6 + 1
925 kusanagi 1.3 do j = 1,16
926     i = i + 1
927 kusanagi 1.6 if (i.gt.sup) RETURN
928     ist = j + 16 * (ipr - 1)
929     dedx(ipl,ist) = vect(i)
930 kusanagi 1.3 enddo
931 kusanagi 1.6 i = i + 1
932     if (i.gt.sup) RETURN
933 kusanagi 1.3 goto 10
934     C
935     endif
936    
937    
938     RETURN
939     END
940    
941    
942 kusanagi 1.5 C----------------------------------------------------------
943 kusanagi 1.3 SUBROUTINE CALFULL(vect,inf,sup,dedx,dedxc,basse)
944 kusanagi 1.5 C--------------------------------------------------------------
945 kusanagi 1.3
946     IMPLICIT NONE
947    
948 kusanagi 1.7 INTEGER*2 VECT(30000)
949 kusanagi 1.3 C
950     INTEGER inf, sup
951     INTEGER i,j,k, iev,iev2
952     C
953     INTEGER NPLA, NCHA, LENSEV
954     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
955     INTEGER merror(4)
956     integer*2 e2(4)
957     INTEGER contr
958 kusanagi 1.6 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
959 kusanagi 1.3
960    
961     real calselftrig(4,7), calIItrig(4), calstripshit(4),
962     & calDSPtaberr(4), calevnum(4)
963    
964    
965     REAL calped(4,11,96), calgood(4,11,96), calthr(4,11,6)
966     REAL calrms(4,11,96), calbase(4,11,6), calvar(4,11,6)
967     REAL calpuls(4,11,96)
968     REAL dedx(11,96), basse(11,6), dedxc(11,96)
969 kusanagi 1.8 real perror(4)
970 kusanagi 1.9 integer stwerr(4),dump
971 kusanagi 1.3
972 kusanagi 1.8 COMMON / evento / IEV, stwerr,perror,
973 kusanagi 1.3 & dexy,dexyc,base,
974     & calselftrig,calIItrig,
975     & calstripshit,calDSPtaberr,calevnum
976    
977     save / evento /
978    
979     COMMON / calib / IEV2, calped, calgood, calthr, calrms,
980     & calbase,
981     & calvar,
982     & calpuls
983    
984     save / calib /
985    
986     c
987 kusanagi 1.9 COMMON / VARIE / merror, CONTR, e2, dump
988 kusanagi 1.3 SAVE / VARIE /
989    
990     C
991     C
992     C
993     DO I = 1,11
994     DO J = 1,96
995     DEDX(I,J) = 0.
996     ENDDO
997     ENDDO
998     C
999 kusanagi 1.6 k = inf
1000 kusanagi 1.3 do i = 1,11
1001     do j = 1,96
1002     dedx(i,j) = vect(k)
1003     k = k + 1
1004     enddo
1005     enddo
1006     C
1007     call CALCOMPRESS(vect,k,sup,dedxc,basse)
1008 kusanagi 1.6 C
1009     10 FORMAT(2X,'Status word:',2X,Z8)
1010 kusanagi 1.3
1011     RETURN
1012     END
1013    
1014    
1015     C------------------------------------------------
1016     SUBROUTINE CONTAER(ve,er)
1017     C------------------------------------------------
1018    
1019     IMPLICIT NONE
1020    
1021     INTEGER*2 VE, st4
1022     C
1023 kusanagi 1.7 INTEGER*2 VECT(30000)
1024 kusanagi 1.3 C
1025     INTEGER er, l, bit, bi, iev,iev2
1026     C
1027     INTEGER NPLA, NCHA, LENSEV
1028     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1029     INTEGER merror(4)
1030     integer*2 e2(4)
1031     INTEGER contr
1032 kusanagi 1.6 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1033 kusanagi 1.3
1034    
1035     real calselftrig(4,7), calIItrig(4), calstripshit(4),
1036     & calDSPtaberr(4), calevnum(4)
1037    
1038    
1039     REAL calped(4,11,96), calgood(4,11,96), calthr(4,11,6)
1040     REAL calrms(4,11,96), calbase(4,11,6), calvar(4,11,6)
1041     REAL calpuls(4,11,96)
1042 kusanagi 1.8 real perror(4)
1043 kusanagi 1.9 integer stwerr(4),dump
1044 kusanagi 1.3
1045 kusanagi 1.8 COMMON / evento / IEV, stwerr,perror,
1046 kusanagi 1.3 & dexy,dexyc,base,
1047     & calselftrig,calIItrig,
1048     & calstripshit,calDSPtaberr,calevnum
1049    
1050     save / evento /
1051    
1052     COMMON / calib / IEV2, calped, calgood, calthr, calrms,
1053     & calbase,
1054     & calvar,
1055     & calpuls
1056    
1057     save / calib /
1058    
1059 kusanagi 1.9 COMMON / VARIE / merror, CONTR, e2,dump
1060 kusanagi 1.3 SAVE / VARIE /
1061    
1062    
1063     st4 = 0
1064     st4 = IAND(ve,'00FF'x)
1065     if (st4.ne.0) then
1066     do bit=0, 6
1067     bi = ibits(st4,bit,1)
1068     if (bi.ne.0) then
1069     er = er + 1
1070     endif
1071     enddo
1072     endif
1073    
1074     10 FORMAT(2X,'Status word:',2X,Z4)
1075     return
1076     end
1077    
1078    
1079     C------------------------------------------------
1080     SUBROUTINE MINERR(ic,icsave,chi,min,co)
1081     C------------------------------------------------
1082    
1083     IMPLICIT NONE
1084     C
1085     INTEGER ic, icsave(1000), chi(1000)
1086     integer l, st, min,co
1087 kusanagi 1.7 INTEGER*2 VECT(30000)
1088 kusanagi 1.3 C
1089     INTEGER iev,iev2
1090     C
1091     INTEGER NPLA, NCHA, LENSEV
1092     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1093     INTEGER merror(4)
1094     integer*2 e2(4)
1095     INTEGER contr
1096 kusanagi 1.6 REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1097 kusanagi 1.3
1098    
1099     real calselftrig(4,7), calIItrig(4), calstripshit(4),
1100     & calDSPtaberr(4), calevnum(4)
1101    
1102    
1103     REAL calped(4,11,96), calgood(4,11,96), calthr(4,11,6)
1104     REAL calrms(4,11,96), calbase(4,11,6), calvar(4,11,6)
1105     REAL calpuls(4,11,96)
1106 kusanagi 1.8 real perror(4)
1107 kusanagi 1.9 integer stwerr(4),dump
1108 kusanagi 1.3
1109 kusanagi 1.8 COMMON / evento / IEV, stwerr,perror,
1110 kusanagi 1.3 & dexy,dexyc,base,
1111     & calselftrig,calIItrig,
1112     & calstripshit,calDSPtaberr,calevnum
1113    
1114     save / evento /
1115    
1116     COMMON / calib / IEV2, calped, calgood, calthr, calrms,
1117     & calbase,
1118     & calvar,
1119     & calpuls
1120    
1121     save / calib /
1122     c
1123 kusanagi 1.9 COMMON / VARIE / merror, CONTR, e2,dump
1124 kusanagi 1.3 SAVE / VARIE /
1125    
1126     st = chi(1)
1127     min = 1
1128     if (co.gt.1) then
1129     do l = 2, co
1130     if (chi(l).lt.st) then
1131     st = chi(l)
1132     min = l
1133     endif
1134     enddo
1135     endif
1136     ic = icsave(min)
1137    
1138     return
1139     end
1140 kusanagi 1.7
1141     C-----------------------------------------------------
1142     SUBROUTINE CANCTUTTO
1143     C-----------------------------------------------------
1144    
1145     IMPLICIT NONE
1146     C
1147     INTEGER iev,iev2
1148     C
1149     INTEGER NPLA, NCHA, LENSEV
1150     PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
1151     INTEGER merror(4)
1152     integer*2 e2(4)
1153     INTEGER contr
1154     REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
1155    
1156    
1157     real calselftrig(4,7), calIItrig(4), calstripshit(4),
1158     & calDSPtaberr(4), calevnum(4)
1159    
1160    
1161     REAL calped(4,11,96), calgood(4,11,96), calthr(4,11,6)
1162     REAL calrms(4,11,96), calbase(4,11,6), calvar(4,11,6)
1163     REAL calpuls(4,11,96)
1164 kusanagi 1.8 real perror(4)
1165 kusanagi 1.9 integer stwerr(4),dump
1166 kusanagi 1.7
1167 kusanagi 1.8 COMMON / evento / IEV, stwerr,perror,
1168 kusanagi 1.7 & dexy,dexyc,base,
1169     & calselftrig,calIItrig,
1170     & calstripshit,calDSPtaberr,calevnum
1171    
1172     save / evento /
1173    
1174     COMMON / calib / IEV2, calped, calgood, calthr, calrms,
1175     & calbase,
1176     & calvar,
1177     & calpuls
1178    
1179     save / calib /
1180     c
1181 kusanagi 1.9 COMMON / VARIE / merror, CONTR, e2,dump
1182 kusanagi 1.7 SAVE / VARIE /
1183     C
1184     call azero(calped,4*11*96)
1185     call azero(calgood,4*11*96)
1186     call azero(calthr,4*11*96)
1187     call azero(calrms,4*11*96)
1188     call azero(calbase,4*11*6)
1189     call azero(calvar,4*11*6)
1190     call azero(calpuls,4*11*96)
1191     call azero(dexy,4*11*96)
1192     call azero(dexyc,4*11*96)
1193     call azero(base,4*11*6)
1194     call azero(calselftrig,4*7)
1195     call azero(calIItrig,4)
1196     call azero(calstripshit,4)
1197     call azero(calDSPtaberr,4)
1198     call azero(calevnum,4)
1199     c
1200     return
1201     end
  ViewVC Help
Powered by ViewVC 1.1.23