forroutines/calorimeter/calpulse.for

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