forroutines/calorimeter/calpulse.for

C
C  Written by Mirko Boezio and Emiliano Mocchiutti
C
C     * Version: 2.18.3 *
C 
C     (see calunpack for changelog)
C
C     - fixed compilation error
C
C------------------------------------------------
      SUBROUTINE CALPULSE(vecta,lung,me)
C------------------------------------------------

      IMPLICIT NONE
C
C Normal variables definition
C
      INTEGER ERROR(4)
C
      INTEGER i, j, iev,iev2, lung, me
      INTEGER NPLA, NCHA, LENSEV
      PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
C
      INTEGER*2 VECT(60000)
      INTEGER*1 VECTA(lung) 
C
      integer*2 check, crc,e2(4)
C
      INTEGER ic, k, ke, ic0
      INTEGER status, CONTR,m 
      INTEGER inf, sup, lunga,lleng,l
      INTEGER XO, YO, XE, YE

      integer st1b, st2b,p,bit,bi,icb, pari
      INTEGER*2 length, length2

      INTEGER*2 st1, st2

      REAL calpuls(4,11,96)

      DATA XO/177/ ! CODE_DSP_R XO = 101 10001
      DATA YO/173/ ! CODE_DSP_R YO = 101 01101
      DATA XE/170/ ! CODE_DSP_R XE = 101 01010
      DATA YE/182/ ! CODE_DSP_R YE = 101 10110

      REAL calped(4,11,96), calgood(4,11,96), calthr(4,11,6)
      REAL calrms(4,11,96), calbase(4,11,6), calvar(4,11,6)

      real calselftrig(4,7), calIItrig(4), calstripshit(4)
      real calDSPtaberr(4), calevnum(4)
      REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
      real perror(4)
      integer stwerr(4), dump

      COMMON / evento / IEV, stwerr,perror,
     &     dexy,dexyc,base,
     &     calselftrig,calIItrig,
     &     calstripshit,calDSPtaberr,calevnum
      
      save / evento /

      COMMON / calib / IEV2, calped, calgood, calthr, calrms, 
     &     calbase,
     &     calvar,
     &     calpuls

      save / calib /

      COMMON /VARIE/ dump, CONTR
      SAVE /VARIE/
    

C         
C Begin !
C
      if (dump.eq.0) dump = -1
      if (iev2.lt.0.or.iev2.gt.9000000) iev2 = 0
      me = 0
      lleng = 0
      ic = 0
c
      pari = 0
      IF (MOD(LUNG,2).EQ.0) THEN
         lunga = lung / 2
         pari = 1
      else
         lunga = int(lung/2) + 1
      endif
c
      if (lunga.gt.60000.and.dump.gt.0) then
         print *,'Calorimeter WARNING: more than 30000 words!'
         lunga = 60000
      endif
c 
      length = ic
c
 20   continue
      ic = ic + length + 1
 32   continue
      ke = 0
      do while (ke.eq.0) 
C
C Check consistency of header.
C it is composed by CODE+D# (8 bits) and by SATUS WORD (8 bits)
c so we must split vect into the two components:
C
C ST1 is CODE + D#
c
         st1b = 0
         st2b = 0
         if ((ic+3).gt.lung) then 
            error(contr) = 130
            if (contr.ne.1) contr=5
            me = 1
            goto 200
         endif
         do bit = 0, 7
            bi = ibits(vecta(ic),bit,1)
            if (bi.eq.1) st1b = ibset(st1b,bit)
            bi = ibits(vecta(ic+1),bit,1)
            if (bi.eq.1) st2b = ibset(st2b,bit)
         enddo
c
C ST2 is the STATUS WORD
c
         length2 = 0
         do bit=0, 7
            bi = ibits(vecta(ic+3),bit,1)
            if (bi.eq.1) length2 = ibset(length2,bit)
            bi = ibits(vecta(ic+2),bit,1)
            if (bi.eq.1) length2 = ibset(length2,bit+8)
         enddo   
c     the crc should be at vect(length) with
         length = length2 + 1 
C
c     some checks to be sure we have found the calorimeter data:
c     
c     status word is always less then 129
c
         if (st2b.gt.128) then
            length = 0
            goto 100
         endif
c
c     length of the packet must be less then 20000 if no errors
c     are found
c
         if (st2b.eq.0.and.length2.gt.lunga) then
            length = 0
            goto 100
         endif
c     
         if (length2.le.0) then
            length = 0
            goto 100
         endif
c
         e2(contr) = 0
C
         if (contr.eq.1) then
c
c     is it the first section?
c
            if (st1b.eq.YE) then
c     if so go out of this loop and go on recording data
               ke = 1
               m = ic
               call riempi(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
c               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
c               endif
               goto 9
            else
c    if not, is it one of the next sections? did we miss a section?
              if (st1b.eq.YO.or.st1b.eq.XE.or.st1b.eq.XO) THEN
c     if so, record an error and go back analizing this section
                 error(contr) = 129
                 contr = 2
                 goto 32
               ELSE
c   if it is not the case, go on with the next value of vect
                  ERROR(contr) = 128  
                  GOTO 100
               endif
            endif
         ENDIF
C            
c     the same for the second section, ...
c
         if (CONTR.eq.2) then     
            if (st1b.eq.YO) then
               ke = 1                  
               m = ic
               call riempi(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
c               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
c               endif
               goto 9
            else
               if (st1b.eq.XE.or.st1b.eq.XO) then
                  error(contr) = 129
                  contr = 3
                  goto 32
               ELSE
                  ERROR(contr) = 128
                  GOTO 100
               endif
            endif
         ENDIF
c
C     ... for the third,...
c
         if (CONTR.eq.3) then
            if (st1b.eq.XE) then
               ke = 1
               m = ic
               call riempi(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
c               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
c               endif
               goto 9
            else
               if (st1b.eq.XO) then
                  error(contr) = 129
                  contr = 4
                  goto 32
               ELSE
                  ERROR(contr) = 128 
                  GOTO 100
               endif
            endif
         ENDIF
C
c     ...and for the last section.
c
         if (CONTR.eq.4) then
            if (st1b.eq.XO) then
               ke = 1
               m = ic
               call riempi(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
c               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
c               endif
            else
c     we should never arrive here (in case we run out of vector if section
c     four is missing!)... however here it is in case of bugs!
c
               ERROR(contr) = 128
               goto 100
            endif  
         endif
C     
 100     CONTINUE
c
c     increment vector of one searching for the next section
c
 9       continue
         ic = ic + 1 
c
c     if we run out of vector give an error and exit the subroutine
c     
         if (ic.gt.(lung-1)) then
            error(contr) = 130
            if (contr.ne.1) contr=5
            me = 1
            goto 200
         endif
      enddo
C              
 10      FORMAT(2X,'Error for view:',2X,I1,2X,'Status word:',2X,Z4)
 11      FORMAT(2X,'View or command not recognized for view:',2X,I1,2X,
     &        'Status word:',2X,Z4)
 12      FORMAT(2X,'Error - did NOT find view:',2X,I1)
 13      FORMAT(2X,'Error - eof reached, exiting')
 21      FORMAT(2X,'CRC: ',2X,Z8)
C
         K = CONTR
         ic0 = icb
         ic = ic - 1
         icb = icb + 1
         length = vect(icb) + 2
         length2 = vect(icb)
         lleng = (length * 2) - 1
C
C Check validity of length.
C
         if (vect(icb).ne.1057) then
            ERROR(contr) = 131
            me = 1 
            goto 200
         endif
C
C Check consistency of CRC.
C
         check = 0.
         inf = ic0
         sup = length - 1
         do i = inf,sup
            check=crc(check,vect(i))
         enddo
         if (check.ne.vect(length)) then
            ERROR(contr) = 132
            me = 1
            goto 200
         endif

      if (iev2.eq.dump) write(*,21)vect(length)
      if (iev2.eq.dump) write(*,21)check      
c
C
C Process data.
C
         if (k.eq.1) then
            k = 4
            goto 49
         endif
         if (k.eq.2) then
            k = 2
            goto 49
         endif
         if (k.eq.3) then
            k = 1
            goto 49 
         endif
         if (k.eq.4) k = 3
c
 49      continue
c
         do j = 1,96
            do i = 1,11
               ic = ic + 1
               if (k.eq.1) then
                  calpuls(k,i,97-j) = vect(icb) 
               else
                  calpuls(k,i,j) = vect(icb) 
               endif
           enddo
         enddo
         CONTR = contr + 1
         me = 0
c  
         if (contr.eq.5) contr = 1
c
 50      continue
c
C     
 200  continue
C
      if (error(1).eq.129.and.error(2).eq.129
     &     .and.error(3).eq.129.and.error(4).eq.130) then
         call azero(error,4)
         me = 1
         contr=1      
      endif
C
      do l = 1, 4
         do bit=0, 31
            if (bit.lt.16) then
               bi = ibits(E2(L),bit,1)
            else
               bi = 0
            endif
            if (l.ne.contr) bi = 0
            if (bi.eq.1) then
               stwerr(l) = ibset(stwerr(l),bit)
            else
               stwerr(l) = ibclr(stwerr(l),bit)
            endif
         enddo
         if (l.eq.contr) then
            perror(l) = float(error(l))
         else
            perror(l) = 0.
         endif
      enddo
C
      if (me.eq.0) iev2 = iev2 + 1 
      RETURN
      END


1	kusanagi	1.7	C
2			C Written by Mirko Boezio and Emiliano Mocchiutti
3			C
4	kusanagi	2.1	C * Version: 2.18.3 *
5	kusanagi	1.7	C
6	kusanagi	1.8	C (see calunpack for changelog)
7	kusanagi	1.9	C
8			C - fixed compilation error
9			C
10	kusanagi	1.3	C------------------------------------------------
11	kusanagi	1.6	SUBROUTINE CALPULSE(vecta,lung,me)
12	kusanagi	1.3	C------------------------------------------------
13
14			IMPLICIT NONE
15			C
16			C Normal variables definition
17			C
18			INTEGER ERROR(4)
19			C
20			INTEGER i, j, iev,iev2, lung, me
21			INTEGER NPLA, NCHA, LENSEV
22			PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
23			C
24	kusanagi	1.8	INTEGER*2 VECT(60000)
25	kusanagi	1.7	INTEGER*1 VECTA(lung)
26	kusanagi	1.3	C
27			integer*2 check, crc,e2(4)
28			C
29			INTEGER ic, k, ke, ic0
30	kusanagi	1.6	INTEGER status, CONTR,m
31	kusanagi	1.7	INTEGER inf, sup, lunga,lleng,l
32	kusanagi	1.3	INTEGER XO, YO, XE, YE
33
34	kusanagi	1.7	integer st1b, st2b,p,bit,bi,icb, pari
35	kusanagi	1.3	INTEGER*2 length, length2
36
37			INTEGER*2 st1, st2
38
39			REAL calpuls(4,11,96)
40
41			DATA XO/177/ ! CODE_DSP_R XO = 101 10001
42			DATA YO/173/ ! CODE_DSP_R YO = 101 01101
43			DATA XE/170/ ! CODE_DSP_R XE = 101 01010
44			DATA YE/182/ ! CODE_DSP_R YE = 101 10110
45
46			REAL calped(4,11,96), calgood(4,11,96), calthr(4,11,6)
47			REAL calrms(4,11,96), calbase(4,11,6), calvar(4,11,6)
48
49			real calselftrig(4,7), calIItrig(4), calstripshit(4)
50			real calDSPtaberr(4), calevnum(4)
51	kusanagi	1.6	REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
52	kusanagi	1.7	real perror(4)
53	kusanagi	1.8	integer stwerr(4), dump
54	kusanagi	1.3
55	kusanagi	1.7	COMMON / evento / IEV, stwerr,perror,
56	kusanagi	1.3	& dexy,dexyc,base,
57			& calselftrig,calIItrig,
58			& calstripshit,calDSPtaberr,calevnum
59
60			save / evento /
61
62			COMMON / calib / IEV2, calped, calgood, calthr, calrms,
63			& calbase,
64			& calvar,
65			& calpuls
66
67			save / calib /
68
69	kusanagi	2.1	COMMON /VARIE/ dump, CONTR
70	kusanagi	1.3	SAVE /VARIE/
71
72
73			C
74			C Begin !
75			C
76	kusanagi	1.8	if (dump.eq.0) dump = -1
77	kusanagi	1.7	if (iev2.lt.0.or.iev2.gt.9000000) iev2 = 0
78	kusanagi	1.3	me = 0
79	kusanagi	1.7	lleng = 0
80	kusanagi	1.3	ic = 0
81	kusanagi	1.7	c
82			pari = 0
83			IF (MOD(LUNG,2).EQ.0) THEN
84			lunga = lung / 2
85			pari = 1
86			else
87			lunga = int(lung/2) + 1
88			endif
89			c
90	kusanagi	1.8	if (lunga.gt.60000.and.dump.gt.0) then
91	kusanagi	2.1	print *,'Calorimeter WARNING: more than 30000 words!'
92	kusanagi	1.8	lunga = 60000
93	kusanagi	1.7	endif
94	kusanagi	1.3	c
95			length = ic
96			c
97			20 continue
98	kusanagi	1.6	ic = ic + length + 1
99	kusanagi	1.5	32 continue
100	kusanagi	1.3	ke = 0
101			do while (ke.eq.0)
102			C
103			C Check consistency of header.
104			C it is composed by CODE+D# (8 bits) and by SATUS WORD (8 bits)
105			c so we must split vect into the two components:
106			C
107			C ST1 is CODE + D#
108	kusanagi	1.6	c
109			st1b = 0
110			st2b = 0
111	kusanagi	1.7	if ((ic+3).gt.lung) then
112			error(contr) = 130
113			if (contr.ne.1) contr=5
114			me = 1
115			goto 200
116			endif
117	kusanagi	1.6	do bit = 0, 7
118			bi = ibits(vecta(ic),bit,1)
119			if (bi.eq.1) st1b = ibset(st1b,bit)
120			bi = ibits(vecta(ic+1),bit,1)
121			if (bi.eq.1) st2b = ibset(st2b,bit)
122			enddo
123			c
124	kusanagi	1.3	C ST2 is the STATUS WORD
125	kusanagi	1.6	c
126			length2 = 0
127			do bit=0, 7
128			bi = ibits(vecta(ic+3),bit,1)
129			if (bi.eq.1) length2 = ibset(length2,bit)
130			bi = ibits(vecta(ic+2),bit,1)
131			if (bi.eq.1) length2 = ibset(length2,bit+8)
132			enddo
133			c the crc should be at vect(length) with
134			length = length2 + 1
135			C
136			c some checks to be sure we have found the calorimeter data:
137			c
138			c status word is always less then 129
139			c
140			if (st2b.gt.128) then
141			length = 0
142			goto 100
143			endif
144			c
145			c length of the packet must be less then 20000 if no errors
146			c are found
147			c
148	kusanagi	1.7	if (st2b.eq.0.and.length2.gt.lunga) then
149	kusanagi	1.6	length = 0
150			goto 100
151			endif
152	kusanagi	1.3	c
153	kusanagi	1.6	if (length2.le.0) then
154			length = 0
155			goto 100
156			endif
157			c
158	kusanagi	1.3	e2(contr) = 0
159			C
160			if (contr.eq.1) then
161	kusanagi	1.6	c
162			c is it the first section?
163			c
164			if (st1b.eq.YE) then
165			c if so go out of this loop and go on recording data
166	kusanagi	1.3	ke = 1
167	kusanagi	1.6	m = ic
168	kusanagi	1.7	call riempi(m,lunga,lleng,lung,pari,vect,vecta)
169	kusanagi	1.6	icb = 1
170	kusanagi	2.1	c if (st2b.ne.0) then
171	kusanagi	1.6	E2(contr) = vect(icb)
172	kusanagi	2.1	c endif
173	kusanagi	1.6	goto 9
174	kusanagi	1.3	else
175	kusanagi	1.6	c if not, is it one of the next sections? did we miss a section?
176			if (st1b.eq.YO.or.st1b.eq.XE.or.st1b.eq.XO) THEN
177			c if so, record an error and go back analizing this section
178			error(contr) = 129
179			contr = 2
180			goto 32
181	kusanagi	1.3	ELSE
182	kusanagi	1.6	c if it is not the case, go on with the next value of vect
183			ERROR(contr) = 128
184	kusanagi	1.3	GOTO 100
185			endif
186			endif
187			ENDIF
188			C
189	kusanagi	1.6	c the same for the second section, ...
190			c
191			if (CONTR.eq.2) then
192			if (st1b.eq.YO) then
193	kusanagi	1.3	ke = 1
194	kusanagi	1.6	m = ic
195	kusanagi	1.7	call riempi(m,lunga,lleng,lung,pari,vect,vecta)
196	kusanagi	1.6	icb = 1
197	kusanagi	2.1	c if (st2b.ne.0) then
198	kusanagi	1.6	E2(contr) = vect(icb)
199	kusanagi	2.1	c endif
200	kusanagi	1.6	goto 9
201	kusanagi	1.3	else
202	kusanagi	1.6	if (st1b.eq.XE.or.st1b.eq.XO) then
203	kusanagi	1.3	error(contr) = 129
204			contr = 3
205	kusanagi	1.5	goto 32
206	kusanagi	1.3	ELSE
207			ERROR(contr) = 128
208			GOTO 100
209			endif
210			endif
211			ENDIF
212	kusanagi	1.6	c
213			C ... for the third,...
214			c
215	kusanagi	1.3	if (CONTR.eq.3) then
216	kusanagi	1.6	if (st1b.eq.XE) then
217	kusanagi	1.3	ke = 1
218	kusanagi	1.6	m = ic
219	kusanagi	1.7	call riempi(m,lunga,lleng,lung,pari,vect,vecta)
220	kusanagi	1.6	icb = 1
221	kusanagi	2.1	c if (st2b.ne.0) then
222	kusanagi	1.6	E2(contr) = vect(icb)
223	kusanagi	2.1	c endif
224	kusanagi	1.6	goto 9
225	kusanagi	1.3	else
226	kusanagi	1.6	if (st1b.eq.XO) then
227	kusanagi	1.3	error(contr) = 129
228			contr = 4
229	kusanagi	1.5	goto 32
230	kusanagi	1.3	ELSE
231	kusanagi	1.6	ERROR(contr) = 128
232	kusanagi	1.3	GOTO 100
233			endif
234			endif
235			ENDIF
236			C
237	kusanagi	1.6	c ...and for the last section.
238			c
239	kusanagi	1.3	if (CONTR.eq.4) then
240	kusanagi	1.6	if (st1b.eq.XO) then
241	kusanagi	1.3	ke = 1
242	kusanagi	1.6	m = ic
243	kusanagi	1.7	call riempi(m,lunga,lleng,lung,pari,vect,vecta)
244	kusanagi	1.6	icb = 1
245	kusanagi	2.1	c if (st2b.ne.0) then
246	kusanagi	1.6	E2(contr) = vect(icb)
247	kusanagi	2.1	c endif
248	kusanagi	1.3	else
249	kusanagi	1.6	c we should never arrive here (in case we run out of vector if section
250			c four is missing!)... however here it is in case of bugs!
251			c
252	kusanagi	1.3	ERROR(contr) = 128
253	kusanagi	1.6	goto 100
254	kusanagi	1.3	endif
255			endif
256			C
257			100 CONTINUE
258	kusanagi	1.6	c
259			c increment vector of one searching for the next section
260			c
261			9 continue
262	kusanagi	1.3	ic = ic + 1
263	kusanagi	1.6	c
264			c if we run out of vector give an error and exit the subroutine
265			c
266	kusanagi	1.7	if (ic.gt.(lung-1)) then
267	kusanagi	1.6	error(contr) = 130
268	kusanagi	1.3	if (contr.ne.1) contr=5
269			me = 1
270			goto 200
271			endif
272			enddo
273			C
274			10 FORMAT(2X,'Error for view:',2X,I1,2X,'Status word:',2X,Z4)
275			11 FORMAT(2X,'View or command not recognized for view:',2X,I1,2X,
276			& 'Status word:',2X,Z4)
277			12 FORMAT(2X,'Error - did NOT find view:',2X,I1)
278			13 FORMAT(2X,'Error - eof reached, exiting')
279	kusanagi	1.9	21 FORMAT(2X,'CRC: ',2X,Z8)
280	kusanagi	1.3	C
281			K = CONTR
282	kusanagi	1.6	ic0 = icb
283			ic = ic - 1
284			icb = icb + 1
285			length = vect(icb) + 2
286			length2 = vect(icb)
287	kusanagi	1.7	lleng = (length * 2) - 1
288	kusanagi	1.3	C
289			C Check validity of length.
290			C
291	kusanagi	1.6	if (vect(icb).ne.1057) then
292	kusanagi	1.3	ERROR(contr) = 131
293			me = 1
294			goto 200
295			endif
296			C
297			C Check consistency of CRC.
298			C
299			check = 0.
300			inf = ic0
301			sup = length - 1
302			do i = inf,sup
303			check=crc(check,vect(i))
304			enddo
305			if (check.ne.vect(length)) then
306			ERROR(contr) = 132
307			me = 1
308			goto 200
309			endif
310	kusanagi	1.8
311	kusanagi	1.9	if (iev2.eq.dump) write(*,21)vect(length)
312			if (iev2.eq.dump) write(*,21)check
313	kusanagi	1.8	c
314	kusanagi	1.3	C
315			C Process data.
316			C
317	kusanagi	1.6	if (k.eq.1) then
318			k = 4
319			goto 49
320			endif
321			if (k.eq.2) then
322			k = 2
323			goto 49
324			endif
325			if (k.eq.3) then
326			k = 1
327			goto 49
328			endif
329			if (k.eq.4) k = 3
330			c
331			49 continue
332			c
333	kusanagi	1.3	do j = 1,96
334			do i = 1,11
335			ic = ic + 1
336	kusanagi	1.6	if (k.eq.1) then
337			calpuls(k,i,97-j) = vect(icb)
338			else
339			calpuls(k,i,j) = vect(icb)
340			endif
341	kusanagi	1.3	enddo
342			enddo
343			CONTR = contr + 1
344			me = 0
345			c
346			if (contr.eq.5) contr = 1
347			c
348			50 continue
349			c
350			C
351			200 continue
352			C
353			if (error(1).eq.129.and.error(2).eq.129
354			& .and.error(3).eq.129.and.error(4).eq.130) then
355	kusanagi	1.5	call azero(error,4)
356	kusanagi	1.3	me = 1
357			contr=1
358			endif
359			C
360	kusanagi	1.7	do l = 1, 4
361			do bit=0, 31
362			if (bit.lt.16) then
363			bi = ibits(E2(L),bit,1)
364			else
365			bi = 0
366			endif
367	kusanagi	2.1	if (l.ne.contr) bi = 0
368			if (bi.eq.1) then
369			stwerr(l) = ibset(stwerr(l),bit)
370			else
371			stwerr(l) = ibclr(stwerr(l),bit)
372			endif
373	kusanagi	1.7	enddo
374	kusanagi	2.1	if (l.eq.contr) then
375			perror(l) = float(error(l))
376			else
377			perror(l) = 0.
378			endif
379	kusanagi	1.7	enddo
380			C
381			if (me.eq.0) iev2 = iev2 + 1
382	kusanagi	1.3	RETURN
383			END
384	kusanagi	2.1
385