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