forroutines/calorimeter/calpulse.for

C
C  Written by Mirko Boezio and Emiliano Mocchiutti
C
C     * Version: 3.1.4 *
C
C     3.1.3 - 3.1.4: (2005-05-26) the decoding is wrong!!! we are reading all strip in one plane per time and not one strip over all planes per time!!!!
C
C     3.1.2 - 3.1.3: (2005-02-23) added some printout in debugging mode.
C
C     3.1.1 - 3.1.2: (2004-12-21) changed common varie.
C
C     3.1.0 - 3.1.1: (2004-12-13) bug in filling the calpuls vector. Fixed.
C
C     3.0.0 - 3.1.0: (2004-12-10) changes in the sections order and increment
C                    iev each time calpulse is called. Cleanup of the code.
C
C     0.00.0 - 3.0.0: (2004-11-08) changes in the commons (one more common for
C                     calpulse and from calstripshit to calstriphit). 
C 
C     - fixed compilation error
C
C------------------------------------------------
      SUBROUTINE CALPULSE(vecta,lung,me)
C------------------------------------------------

      IMPLICIT NONE
C
C Normal variables definition
C
      INTEGER i, j, lung, me
      INTEGER NPLA, NCHA, LENSEV
      PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
C
      INTEGER*2 VECT(60000)
      INTEGER*1 VECTA(lung) 
      integer*2 check, crc,e2(4)
      INTEGER*2 length, length2
C
      INTEGER ERROR(4), merror(4)
      INTEGER ic, k, ke, ic0
      INTEGER CONTR, m 
      INTEGER inf, sup, lunga,lleng,l
      INTEGER XO, YO, XE, YE
      integer pstwerr(4), IEV
      integer dump
      integer st1b, st2b, bit,bi,icb, pari

      real pperror(4)
      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

      COMMON / calpul / iev, pstwerr, pperror,
     &     calpuls

      save / calpul /
c

      COMMON /VARIE/ dump, CONTR, merror
      SAVE /VARIE/
    

C         
C Begin !
C
      if (dump.eq.0) dump = -1
      if (iev.lt.0.or.iev.gt.9000000) iev = 0
      call clearall
      do i = 1, 4
         pstwerr(i) = 0
         pperror(i) = 0.
         error(i) = 0
         e2(i) = 0
      enddo
      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
         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
c     is it the first section?
c     
         if (st1b.eq.XE.and.length2.eq.1057) then
c     if so go out of this loop and go on recording data
            ke = 1
            m = ic
            contr = 1 
            if (iev.eq.dump) then
               print *,'1m,lunga,lleng,lung,pari',m,lunga,lleng,lung,
     &              pari
            endif
            call fillin(m,lunga,lleng,lung,pari,vect,vecta)
            icb = 1
            E2(contr) = vect(icb)
            goto 9
         ENDIF
C            
c     the same for the second section, ...
C
         if (st1b.eq.XO.and.length2.eq.1057) then
            contr = 2
            ke = 1                  
            m = ic
            call fillin(m,lunga,lleng,lung,pari,vect,vecta)
            icb = 1
            E2(contr) = vect(icb)
            goto 9
         ENDIF
c
C     ... for the third,...
c
         if (st1b.eq.YE.and.length2.eq.1057) then
            contr = 3
            ke = 1
            m = ic
            call fillin(m,lunga,lleng,lung,pari,vect,vecta)
            icb = 1
            E2(contr) = vect(icb)
            goto 9
         ENDIF
C
c     ...and for the last section.
c
         if (st1b.eq.YO.and.length2.eq.1057) then
            contr = 4
            ke = 1
            m = ic
            call fillin(m,lunga,lleng,lung,pari,vect,vecta)
            icb = 1
            E2(contr) = vect(icb)
         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
            me = 1
c            print *,'1 me = 1'
            call clearall
            do i = 1, 4
               error(i) = 129            
               e2(i) = 0            
               pstwerr(i) = 0
            enddo
            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 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
c            print *,'2 me = 1'
            me = 1
            goto 200
         endif         

      if (iev.eq.dump) write(*,21)vect(length)
      if (iev.eq.dump) write(*,21)check      
c
C
C Process data.
C
         if (k.eq.1) then
            k = 1
            goto 49
         endif
         if (k.eq.2) then
            k = 3
            goto 49
         endif
         if (k.eq.3) then
            k = 4
            goto 49 
         endif
         if (k.eq.4) k = 2
c
 49      continue
c
         do i = 1,11
            do j = 1,96
               icb = icb + 1
               if (k.eq.1) then
                  calpuls(k,i,97-j) = vect(icb) 
               else
                  calpuls(k,i,j) = vect(icb) 
               endif
           enddo
         enddo
c         print *,'3 me = 0'
         me = 0
c
 50      continue
c
C     
 200  continue
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
               pstwerr(l) = ibset(pstwerr(l),bit)
            else
               pstwerr(l) = ibclr(pstwerr(l),bit)
            endif
         enddo
         pperror(l) = float(error(l))
      enddo
C
      iev = iev + 1 
      RETURN
      END


1	kusanagi	1.7	C
2			C Written by Mirko Boezio and Emiliano Mocchiutti
3			C
4	kusanagi	4.1	C * Version: 3.1.4 *
5			C
6			C 3.1.3 - 3.1.4: (2005-05-26) the decoding is wrong!!! we are reading all strip in one plane per time and not one strip over all planes per time!!!!
7	kusanagi	2.6	C
8			C 3.1.2 - 3.1.3: (2005-02-23) added some printout in debugging mode.
9	kusanagi	2.5	C
10			C 3.1.1 - 3.1.2: (2004-12-21) changed common varie.
11	kusanagi	2.4	C
12			C 3.1.0 - 3.1.1: (2004-12-13) bug in filling the calpuls vector. Fixed.
13			C
14			C 3.0.0 - 3.1.0: (2004-12-10) changes in the sections order and increment
15			C iev each time calpulse is called. Cleanup of the code.
16	kusanagi	2.3	C
17			C 0.00.0 - 3.0.0: (2004-11-08) changes in the commons (one more common for
18			C calpulse and from calstripshit to calstriphit).
19	kusanagi	1.7	C
20	kusanagi	1.9	C - fixed compilation error
21			C
22	kusanagi	1.3	C------------------------------------------------
23	kusanagi	1.6	SUBROUTINE CALPULSE(vecta,lung,me)
24	kusanagi	1.3	C------------------------------------------------
25
26			IMPLICIT NONE
27			C
28			C Normal variables definition
29			C
30	kusanagi	2.4	INTEGER i, j, lung, me
31	kusanagi	1.3	INTEGER NPLA, NCHA, LENSEV
32			PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
33			C
34	kusanagi	1.8	INTEGER*2 VECT(60000)
35	kusanagi	1.7	INTEGER*1 VECTA(lung)
36	kusanagi	1.3	integer*2 check, crc,e2(4)
37	kusanagi	2.4	INTEGER*2 length, length2
38	kusanagi	1.3	C
39	kusanagi	2.5	INTEGER ERROR(4), merror(4)
40	kusanagi	1.3	INTEGER ic, k, ke, ic0
41	kusanagi	2.4	INTEGER CONTR, m
42	kusanagi	1.7	INTEGER inf, sup, lunga,lleng,l
43	kusanagi	1.3	INTEGER XO, YO, XE, YE
44	kusanagi	2.4	integer pstwerr(4), IEV
45			integer dump
46			integer st1b, st2b, bit,bi,icb, pari
47	kusanagi	1.3
48	kusanagi	2.4	real pperror(4)
49	kusanagi	1.3	REAL calpuls(4,11,96)
50
51			DATA XO/177/ ! CODE_DSP_R XO = 101 10001
52			DATA YO/173/ ! CODE_DSP_R YO = 101 01101
53			DATA XE/170/ ! CODE_DSP_R XE = 101 01010
54			DATA YE/182/ ! CODE_DSP_R YE = 101 10110
55
56	kusanagi	2.4	COMMON / calpul / iev, pstwerr, pperror,
57	kusanagi	1.3	& calpuls
58
59	kusanagi	2.3	save / calpul /
60			c
61	kusanagi	1.3
62	kusanagi	2.5	COMMON /VARIE/ dump, CONTR, merror
63	kusanagi	1.3	SAVE /VARIE/
64
65
66			C
67			C Begin !
68			C
69	kusanagi	1.8	if (dump.eq.0) dump = -1
70	kusanagi	2.4	if (iev.lt.0.or.iev.gt.9000000) iev = 0
71			call clearall
72			do i = 1, 4
73			pstwerr(i) = 0
74			pperror(i) = 0.
75			error(i) = 0
76			e2(i) = 0
77			enddo
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			do bit = 0, 7
112			bi = ibits(vecta(ic),bit,1)
113			if (bi.eq.1) st1b = ibset(st1b,bit)
114			bi = ibits(vecta(ic+1),bit,1)
115			if (bi.eq.1) st2b = ibset(st2b,bit)
116			enddo
117			c
118	kusanagi	1.3	C ST2 is the STATUS WORD
119	kusanagi	1.6	c
120			length2 = 0
121			do bit=0, 7
122			bi = ibits(vecta(ic+3),bit,1)
123			if (bi.eq.1) length2 = ibset(length2,bit)
124			bi = ibits(vecta(ic+2),bit,1)
125			if (bi.eq.1) length2 = ibset(length2,bit+8)
126			enddo
127			c the crc should be at vect(length) with
128			length = length2 + 1
129			C
130			c some checks to be sure we have found the calorimeter data:
131			c
132			c status word is always less then 129
133			c
134			if (st2b.gt.128) then
135			length = 0
136			goto 100
137			endif
138			c
139			c length of the packet must be less then 20000 if no errors
140			c are found
141			c
142	kusanagi	1.7	if (st2b.eq.0.and.length2.gt.lunga) then
143	kusanagi	1.6	length = 0
144			goto 100
145			endif
146	kusanagi	1.3	c
147	kusanagi	1.6	if (length2.le.0) then
148			length = 0
149			goto 100
150			endif
151			c
152			c is it the first section?
153	kusanagi	2.4	c
154			if (st1b.eq.XE.and.length2.eq.1057) then
155	kusanagi	1.6	c if so go out of this loop and go on recording data
156	kusanagi	2.4	ke = 1
157			m = ic
158			contr = 1
159	kusanagi	2.6	if (iev.eq.dump) then
160			print *,'1m,lunga,lleng,lung,pari',m,lunga,lleng,lung,
161			& pari
162			endif
163	kusanagi	2.4	call fillin(m,lunga,lleng,lung,pari,vect,vecta)
164			icb = 1
165			E2(contr) = vect(icb)
166			goto 9
167	kusanagi	1.3	ENDIF
168			C
169	kusanagi	1.6	c the same for the second section, ...
170	kusanagi	2.4	C
171			if (st1b.eq.XO.and.length2.eq.1057) then
172			contr = 2
173			ke = 1
174			m = ic
175			call fillin(m,lunga,lleng,lung,pari,vect,vecta)
176			icb = 1
177			E2(contr) = vect(icb)
178			goto 9
179	kusanagi	1.3	ENDIF
180	kusanagi	1.6	c
181			C ... for the third,...
182			c
183	kusanagi	2.4	if (st1b.eq.YE.and.length2.eq.1057) then
184			contr = 3
185			ke = 1
186			m = ic
187			call fillin(m,lunga,lleng,lung,pari,vect,vecta)
188			icb = 1
189			E2(contr) = vect(icb)
190			goto 9
191	kusanagi	1.3	ENDIF
192			C
193	kusanagi	1.6	c ...and for the last section.
194			c
195	kusanagi	2.4	if (st1b.eq.YO.and.length2.eq.1057) then
196			contr = 4
197			ke = 1
198			m = ic
199			call fillin(m,lunga,lleng,lung,pari,vect,vecta)
200			icb = 1
201			E2(contr) = vect(icb)
202	kusanagi	1.3	endif
203			C
204			100 CONTINUE
205	kusanagi	1.6	c
206			c increment vector of one searching for the next section
207			c
208			9 continue
209	kusanagi	1.3	ic = ic + 1
210	kusanagi	1.6	c
211			c if we run out of vector give an error and exit the subroutine
212			c
213	kusanagi	1.7	if (ic.gt.(lung-1)) then
214	kusanagi	1.3	me = 1
215	kusanagi	4.1	c print *,'1 me = 1'
216	kusanagi	2.4	call clearall
217			do i = 1, 4
218			error(i) = 129
219			e2(i) = 0
220			pstwerr(i) = 0
221			enddo
222	kusanagi	1.3	goto 200
223			endif
224			enddo
225			C
226			10 FORMAT(2X,'Error for view:',2X,I1,2X,'Status word:',2X,Z4)
227			11 FORMAT(2X,'View or command not recognized for view:',2X,I1,2X,
228			& 'Status word:',2X,Z4)
229			12 FORMAT(2X,'Error - did NOT find view:',2X,I1)
230			13 FORMAT(2X,'Error - eof reached, exiting')
231	kusanagi	1.9	21 FORMAT(2X,'CRC: ',2X,Z8)
232	kusanagi	2.4	C
233	kusanagi	1.3	K = CONTR
234	kusanagi	1.6	ic0 = icb
235			ic = ic - 1
236			icb = icb + 1
237			length = vect(icb) + 2
238			length2 = vect(icb)
239	kusanagi	1.7	lleng = (length * 2) - 1
240	kusanagi	1.3	C
241			C Check consistency of CRC.
242			C
243			check = 0.
244			inf = ic0
245			sup = length - 1
246			do i = inf,sup
247			check=crc(check,vect(i))
248			enddo
249			if (check.ne.vect(length)) then
250			ERROR(contr) = 132
251	kusanagi	4.1	c print *,'2 me = 1'
252	kusanagi	1.3	me = 1
253			goto 200
254	kusanagi	2.4	endif
255	kusanagi	1.8
256	kusanagi	2.4	if (iev.eq.dump) write(*,21)vect(length)
257			if (iev.eq.dump) write(*,21)check
258	kusanagi	1.8	c
259	kusanagi	1.3	C
260			C Process data.
261			C
262	kusanagi	1.6	if (k.eq.1) then
263	kusanagi	2.4	k = 1
264	kusanagi	1.6	goto 49
265			endif
266			if (k.eq.2) then
267	kusanagi	2.4	k = 3
268	kusanagi	1.6	goto 49
269			endif
270			if (k.eq.3) then
271	kusanagi	2.4	k = 4
272	kusanagi	1.6	goto 49
273			endif
274	kusanagi	2.4	if (k.eq.4) k = 2
275	kusanagi	1.6	c
276			49 continue
277			c
278	kusanagi	4.1	do i = 1,11
279			do j = 1,96
280	kusanagi	2.4	icb = icb + 1
281	kusanagi	1.6	if (k.eq.1) then
282			calpuls(k,i,97-j) = vect(icb)
283			else
284			calpuls(k,i,j) = vect(icb)
285			endif
286	kusanagi	1.3	enddo
287			enddo
288	kusanagi	4.1	c print *,'3 me = 0'
289	kusanagi	1.3	me = 0
290			c
291			50 continue
292			c
293			C
294			200 continue
295			C
296	kusanagi	1.7	do l = 1, 4
297			do bit=0, 31
298			if (bit.lt.16) then
299			bi = ibits(E2(L),bit,1)
300			else
301			bi = 0
302			endif
303	kusanagi	2.1	if (l.ne.contr) bi = 0
304			if (bi.eq.1) then
305	kusanagi	2.3	pstwerr(l) = ibset(pstwerr(l),bit)
306	kusanagi	2.1	else
307	kusanagi	2.3	pstwerr(l) = ibclr(pstwerr(l),bit)
308	kusanagi	2.1	endif
309	kusanagi	1.7	enddo
310	kusanagi	2.4	pperror(l) = float(error(l))
311	kusanagi	1.7	enddo
312			C
313	kusanagi	2.4	iev = iev + 1
314	kusanagi	1.3	RETURN
315			END
316	kusanagi	2.1
317