forroutines/calorimeter/calpulse.for

C
C  Written by Mirko Boezio and Emiliano Mocchiutti
C
C     * Version: 3.1.7 *
C
C     3.1.6 - 3.1.7: (2006-06-29) another bug related to XO is rotated, not XE!! fixed.
C
C     3.1.5 - 3.1.6: (2006-06-29) XO is rotated, not XE!! fixed.
C
C     3.1.4 - 3.1.5: (2006-06-29) save in calpuls(section,1,1) and calpuls(section,1,2) the CRC values (transmitted and calculated) in case of CRC errors
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'
            calpuls(k,1,1) = check
            calpuls(k,1,2) = vect(length)            
            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.3) 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	6.1	C * Version: 3.1.7 *
5			C
6			C 3.1.6 - 3.1.7: (2006-06-29) another bug related to XO is rotated, not XE!! fixed.
7			C
8			C 3.1.5 - 3.1.6: (2006-06-29) XO is rotated, not XE!! fixed.
9			C
10			C 3.1.4 - 3.1.5: (2006-06-29) save in calpuls(section,1,1) and calpuls(section,1,2) the CRC values (transmitted and calculated) in case of CRC errors
11	kusanagi	4.1	C
12			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!!!!
13	kusanagi	2.6	C
14			C 3.1.2 - 3.1.3: (2005-02-23) added some printout in debugging mode.
15	kusanagi	2.5	C
16			C 3.1.1 - 3.1.2: (2004-12-21) changed common varie.
17	kusanagi	2.4	C
18			C 3.1.0 - 3.1.1: (2004-12-13) bug in filling the calpuls vector. Fixed.
19			C
20			C 3.0.0 - 3.1.0: (2004-12-10) changes in the sections order and increment
21			C iev each time calpulse is called. Cleanup of the code.
22	kusanagi	2.3	C
23			C 0.00.0 - 3.0.0: (2004-11-08) changes in the commons (one more common for
24			C calpulse and from calstripshit to calstriphit).
25	kusanagi	1.7	C
26	kusanagi	1.9	C - fixed compilation error
27			C
28	kusanagi	1.3	C------------------------------------------------
29	kusanagi	1.6	SUBROUTINE CALPULSE(vecta,lung,me)
30	kusanagi	1.3	C------------------------------------------------
31
32			IMPLICIT NONE
33			C
34			C Normal variables definition
35			C
36	kusanagi	2.4	INTEGER i, j, lung, me
37	kusanagi	1.3	INTEGER NPLA, NCHA, LENSEV
38			PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
39			C
40	kusanagi	1.8	INTEGER*2 VECT(60000)
41	kusanagi	1.7	INTEGER*1 VECTA(lung)
42	kusanagi	1.3	integer*2 check, crc,e2(4)
43	kusanagi	2.4	INTEGER*2 length, length2
44	kusanagi	1.3	C
45	kusanagi	2.5	INTEGER ERROR(4), merror(4)
46	kusanagi	1.3	INTEGER ic, k, ke, ic0
47	kusanagi	2.4	INTEGER CONTR, m
48	kusanagi	1.7	INTEGER inf, sup, lunga,lleng,l
49	kusanagi	1.3	INTEGER XO, YO, XE, YE
50	kusanagi	2.4	integer pstwerr(4), IEV
51			integer dump
52			integer st1b, st2b, bit,bi,icb, pari
53	kusanagi	1.3
54	kusanagi	2.4	real pperror(4)
55	kusanagi	1.3	REAL calpuls(4,11,96)
56
57			DATA XO/177/ ! CODE_DSP_R XO = 101 10001
58			DATA YO/173/ ! CODE_DSP_R YO = 101 01101
59			DATA XE/170/ ! CODE_DSP_R XE = 101 01010
60			DATA YE/182/ ! CODE_DSP_R YE = 101 10110
61
62	kusanagi	2.4	COMMON / calpul / iev, pstwerr, pperror,
63	kusanagi	1.3	& calpuls
64
65	kusanagi	2.3	save / calpul /
66			c
67	kusanagi	1.3
68	kusanagi	2.5	COMMON /VARIE/ dump, CONTR, merror
69	kusanagi	1.3	SAVE /VARIE/
70
71
72			C
73			C Begin !
74			C
75	kusanagi	1.8	if (dump.eq.0) dump = -1
76	kusanagi	2.4	if (iev.lt.0.or.iev.gt.9000000) iev = 0
77			call clearall
78			do i = 1, 4
79			pstwerr(i) = 0
80			pperror(i) = 0.
81			error(i) = 0
82			e2(i) = 0
83			enddo
84	kusanagi	1.3	me = 0
85	kusanagi	1.7	lleng = 0
86	kusanagi	1.3	ic = 0
87	kusanagi	1.7	c
88			pari = 0
89			IF (MOD(LUNG,2).EQ.0) THEN
90			lunga = lung / 2
91			pari = 1
92			else
93			lunga = int(lung/2) + 1
94			endif
95			c
96	kusanagi	1.8	if (lunga.gt.60000.and.dump.gt.0) then
97	kusanagi	2.1	print *,'Calorimeter WARNING: more than 30000 words!'
98	kusanagi	1.8	lunga = 60000
99	kusanagi	1.7	endif
100	kusanagi	1.3	c
101			length = ic
102			c
103			20 continue
104	kusanagi	1.6	ic = ic + length + 1
105	kusanagi	1.5	32 continue
106	kusanagi	1.3	ke = 0
107			do while (ke.eq.0)
108			C
109			C Check consistency of header.
110			C it is composed by CODE+D# (8 bits) and by SATUS WORD (8 bits)
111			c so we must split vect into the two components:
112			C
113			C ST1 is CODE + D#
114	kusanagi	1.6	c
115			st1b = 0
116			st2b = 0
117			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			c is it the first section?
159	kusanagi	2.4	c
160			if (st1b.eq.XE.and.length2.eq.1057) then
161	kusanagi	1.6	c if so go out of this loop and go on recording data
162	kusanagi	2.4	ke = 1
163			m = ic
164			contr = 1
165	kusanagi	2.6	if (iev.eq.dump) then
166			print *,'1m,lunga,lleng,lung,pari',m,lunga,lleng,lung,
167			& pari
168			endif
169	kusanagi	2.4	call fillin(m,lunga,lleng,lung,pari,vect,vecta)
170			icb = 1
171			E2(contr) = vect(icb)
172			goto 9
173	kusanagi	1.3	ENDIF
174			C
175	kusanagi	1.6	c the same for the second section, ...
176	kusanagi	2.4	C
177			if (st1b.eq.XO.and.length2.eq.1057) then
178			contr = 2
179			ke = 1
180			m = ic
181			call fillin(m,lunga,lleng,lung,pari,vect,vecta)
182			icb = 1
183			E2(contr) = vect(icb)
184			goto 9
185	kusanagi	1.3	ENDIF
186	kusanagi	1.6	c
187			C ... for the third,...
188			c
189	kusanagi	2.4	if (st1b.eq.YE.and.length2.eq.1057) then
190			contr = 3
191			ke = 1
192			m = ic
193			call fillin(m,lunga,lleng,lung,pari,vect,vecta)
194			icb = 1
195			E2(contr) = vect(icb)
196			goto 9
197	kusanagi	1.3	ENDIF
198			C
199	kusanagi	1.6	c ...and for the last section.
200			c
201	kusanagi	2.4	if (st1b.eq.YO.and.length2.eq.1057) then
202			contr = 4
203			ke = 1
204			m = ic
205			call fillin(m,lunga,lleng,lung,pari,vect,vecta)
206			icb = 1
207			E2(contr) = vect(icb)
208	kusanagi	1.3	endif
209			C
210			100 CONTINUE
211	kusanagi	1.6	c
212			c increment vector of one searching for the next section
213			c
214			9 continue
215	kusanagi	1.3	ic = ic + 1
216	kusanagi	1.6	c
217			c if we run out of vector give an error and exit the subroutine
218			c
219	kusanagi	1.7	if (ic.gt.(lung-1)) then
220	kusanagi	1.3	me = 1
221	kusanagi	4.1	c print *,'1 me = 1'
222	kusanagi	2.4	call clearall
223			do i = 1, 4
224			error(i) = 129
225			e2(i) = 0
226			pstwerr(i) = 0
227			enddo
228	kusanagi	1.3	goto 200
229			endif
230			enddo
231			C
232			10 FORMAT(2X,'Error for view:',2X,I1,2X,'Status word:',2X,Z4)
233			11 FORMAT(2X,'View or command not recognized for view:',2X,I1,2X,
234			& 'Status word:',2X,Z4)
235			12 FORMAT(2X,'Error - did NOT find view:',2X,I1)
236			13 FORMAT(2X,'Error - eof reached, exiting')
237	kusanagi	1.9	21 FORMAT(2X,'CRC: ',2X,Z8)
238	kusanagi	2.4	C
239	kusanagi	1.3	K = CONTR
240	kusanagi	1.6	ic0 = icb
241			ic = ic - 1
242			icb = icb + 1
243			length = vect(icb) + 2
244			length2 = vect(icb)
245	kusanagi	1.7	lleng = (length * 2) - 1
246	kusanagi	1.3	C
247			C Check consistency of CRC.
248			C
249			check = 0.
250			inf = ic0
251			sup = length - 1
252			do i = inf,sup
253			check=crc(check,vect(i))
254			enddo
255			if (check.ne.vect(length)) then
256			ERROR(contr) = 132
257	kusanagi	4.1	c print *,'2 me = 1'
258	kusanagi	6.1	calpuls(k,1,1) = check
259			calpuls(k,1,2) = vect(length)
260	kusanagi	1.3	me = 1
261			goto 200
262	kusanagi	2.4	endif
263	kusanagi	1.8
264	kusanagi	2.4	if (iev.eq.dump) write(*,21)vect(length)
265			if (iev.eq.dump) write(*,21)check
266	kusanagi	1.8	c
267	kusanagi	1.3	C
268			C Process data.
269			C
270	kusanagi	1.6	if (k.eq.1) then
271	kusanagi	2.4	k = 1
272	kusanagi	1.6	goto 49
273			endif
274			if (k.eq.2) then
275	kusanagi	2.4	k = 3
276	kusanagi	1.6	goto 49
277			endif
278			if (k.eq.3) then
279	kusanagi	2.4	k = 4
280	kusanagi	1.6	goto 49
281			endif
282	kusanagi	2.4	if (k.eq.4) k = 2
283	kusanagi	1.6	c
284			49 continue
285			c
286	kusanagi	4.1	do i = 1,11
287			do j = 1,96
288	kusanagi	2.4	icb = icb + 1
289	kusanagi	6.1	if (k.eq.3) then
290	kusanagi	1.6	calpuls(k,i,97-j) = vect(icb)
291			else
292			calpuls(k,i,j) = vect(icb)
293			endif
294	kusanagi	1.3	enddo
295			enddo
296	kusanagi	4.1	c print *,'3 me = 0'
297	kusanagi	1.3	me = 0
298			c
299			50 continue
300			c
301			C
302			200 continue
303			C
304	kusanagi	1.7	do l = 1, 4
305			do bit=0, 31
306			if (bit.lt.16) then
307			bi = ibits(E2(L),bit,1)
308			else
309			bi = 0
310			endif
311	kusanagi	2.1	if (l.ne.contr) bi = 0
312			if (bi.eq.1) then
313	kusanagi	2.3	pstwerr(l) = ibset(pstwerr(l),bit)
314	kusanagi	2.1	else
315	kusanagi	2.3	pstwerr(l) = ibclr(pstwerr(l),bit)
316	kusanagi	2.1	endif
317	kusanagi	1.7	enddo
318	kusanagi	2.4	pperror(l) = float(error(l))
319	kusanagi	1.7	enddo
320			C
321	kusanagi	2.4	iev = iev + 1
322	kusanagi	1.3	RETURN
323			END
324	kusanagi	2.1
325