forroutines/calorimeter/calpulse.for

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