forroutines/calorimeter/calpulse.for

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