/[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 2.1 - (hide annotations) (download)
Sun Oct 17 12:28:43 2004 UTC (20 years, 2 months ago) by kusanagi
Branch: MAIN
Changes since 2.0: +86 -33 lines
*** empty log message ***

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

  ViewVC Help
Powered by ViewVC 1.1.23