forroutines/calorimeter/calpulse.for

C
C  Written by Mirko Boezio and Emiliano Mocchiutti
C
C     * Version: 2.17 *
C 
C------------------------------------------------
      SUBROUTINE CALPULSE(vecta,lung,me)
C------------------------------------------------

      IMPLICIT NONE
C
C Normal variables definition
C
      INTEGER ERROR(4)
C
      INTEGER i, j, iev,iev2, lung, me
      INTEGER NPLA, NCHA, LENSEV
      PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
C
      INTEGER*2 VECT(30000)
      INTEGER*1 VECTA(lung) 
C
      integer*2 check, crc,e2(4)
C
      INTEGER ic, k, ke, ic0
      INTEGER status, CONTR,m 
      INTEGER inf, sup, lunga,lleng,l
      INTEGER XO, YO, XE, YE

      integer st1b, st2b,p,bit,bi,icb, pari
      INTEGER*2 length, length2

      INTEGER*2 st1, st2

      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

      REAL calped(4,11,96), calgood(4,11,96), calthr(4,11,6)
      REAL calrms(4,11,96), calbase(4,11,6), calvar(4,11,6)

      real calselftrig(4,7), calIItrig(4), calstripshit(4)
      real calDSPtaberr(4), calevnum(4)
      REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
      real perror(4)
      integer stwerr(4)

      COMMON / evento / IEV, stwerr,perror,
     &     dexy,dexyc,base,
     &     calselftrig,calIItrig,
     &     calstripshit,calDSPtaberr,calevnum
      
      save / evento /

      COMMON / calib / IEV2, calped, calgood, calthr, calrms, 
     &     calbase,
     &     calvar,
     &     calpuls

      save / calib /

      COMMON /VARIE/ error, CONTR, e2
      SAVE /VARIE/
    

C         
C Begin !
C
      if (iev2.lt.0.or.iev2.gt.9000000) iev2 = 0
      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.30000) then
c         print *,'Calorimeter WARNING: more than 30000 words!'
         lunga = 30000
      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
         if ((ic+3).gt.lung) then 
            error(contr) = 130
            if (contr.ne.1) contr=5
            me = 1
            goto 200
         endif
         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
         e2(contr) = 0
C
         if (contr.eq.1) then
c
c     is it the first section?
c
            if (st1b.eq.YE) then
c     if so go out of this loop and go on recording data
               ke = 1
               m = ic
               call riempi(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
               endif
               goto 9
            else
c    if not, is it one of the next sections? did we miss a section?
              if (st1b.eq.YO.or.st1b.eq.XE.or.st1b.eq.XO) THEN
c     if so, record an error and go back analizing this section
                 error(contr) = 129
                 contr = 2
                 goto 32
               ELSE
c   if it is not the case, go on with the next value of vect
                  ERROR(contr) = 128  
                  GOTO 100
               endif
            endif
         ENDIF
C            
c     the same for the second section, ...
c
         if (CONTR.eq.2) then     
            if (st1b.eq.YO) then
               ke = 1                  
               m = ic
               call riempi(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
               endif
               goto 9
            else
               if (st1b.eq.XE.or.st1b.eq.XO) then
                  error(contr) = 129
                  contr = 3
                  goto 32
               ELSE
                  ERROR(contr) = 128
                  GOTO 100
               endif
            endif
         ENDIF
c
C     ... for the third,...
c
         if (CONTR.eq.3) then
            if (st1b.eq.XE) then
               ke = 1
               m = ic
               call riempi(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
               endif
               goto 9
            else
               if (st1b.eq.XO) then
                  error(contr) = 129
                  contr = 4
                  goto 32
               ELSE
                  ERROR(contr) = 128 
                  GOTO 100
               endif
            endif
         ENDIF
C
c     ...and for the last section.
c
         if (CONTR.eq.4) then
            if (st1b.eq.XO) then
               ke = 1
               m = ic
               call riempi(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
               endif
            else
c     we should never arrive here (in case we run out of vector if section
c     four is missing!)... however here it is in case of bugs!
c
               ERROR(contr) = 128
               goto 100
            endif  
         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
            error(contr) = 130
            if (contr.ne.1) contr=5
            me = 1
            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')
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 validity of length.
C
         if (vect(icb).ne.1057) then
            ERROR(contr) = 131
            me = 1 
            goto 200
         endif
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
C
C Process data.
C
         if (k.eq.1) then
            k = 4
            goto 49
         endif
         if (k.eq.2) then
            k = 2
            goto 49
         endif
         if (k.eq.3) then
            k = 1
            goto 49 
         endif
         if (k.eq.4) k = 3
c
 49      continue
c
         do j = 1,96
            do i = 1,11
               ic = ic + 1
               if (k.eq.1) then
                  calpuls(k,i,97-j) = vect(icb) 
               else
                  calpuls(k,i,j) = vect(icb) 
               endif
           enddo
         enddo
         CONTR = contr + 1
         me = 0
c  
         if (contr.eq.5) contr = 1
c
 50      continue
c
C     
 200  continue
C
      if (error(1).eq.129.and.error(2).eq.129
     &     .and.error(3).eq.129.and.error(4).eq.130) then
         call azero(error,4)
         me = 1
         contr=1      
      endif
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 (bi.eq.1) stwerr(l) = ibset(stwerr(l),bit)
         enddo
         perror(l) = float(error(l))
      enddo
C
      if (me.eq.0) iev2 = iev2 + 1 
      RETURN
      END


1	kusanagi	1.7	C
2			C Written by Mirko Boezio and Emiliano Mocchiutti
3			C
4			C * Version: 2.17 *
5			C
6	kusanagi	1.3	C------------------------------------------------
7	kusanagi	1.6	SUBROUTINE CALPULSE(vecta,lung,me)
8	kusanagi	1.3	C------------------------------------------------
9
10			IMPLICIT NONE
11			C
12			C Normal variables definition
13			C
14			INTEGER ERROR(4)
15			C
16			INTEGER i, j, iev,iev2, lung, me
17			INTEGER NPLA, NCHA, LENSEV
18			PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
19			C
20	kusanagi	1.7	INTEGER*2 VECT(30000)
21			INTEGER*1 VECTA(lung)
22	kusanagi	1.3	C
23			integer*2 check, crc,e2(4)
24			C
25			INTEGER ic, k, ke, ic0
26	kusanagi	1.6	INTEGER status, CONTR,m
27	kusanagi	1.7	INTEGER inf, sup, lunga,lleng,l
28	kusanagi	1.3	INTEGER XO, YO, XE, YE
29
30	kusanagi	1.7	integer st1b, st2b,p,bit,bi,icb, pari
31	kusanagi	1.3	INTEGER*2 length, length2
32
33			INTEGER*2 st1, st2
34
35			REAL calpuls(4,11,96)
36
37			DATA XO/177/ ! CODE_DSP_R XO = 101 10001
38			DATA YO/173/ ! CODE_DSP_R YO = 101 01101
39			DATA XE/170/ ! CODE_DSP_R XE = 101 01010
40			DATA YE/182/ ! CODE_DSP_R YE = 101 10110
41
42			REAL calped(4,11,96), calgood(4,11,96), calthr(4,11,6)
43			REAL calrms(4,11,96), calbase(4,11,6), calvar(4,11,6)
44
45			real calselftrig(4,7), calIItrig(4), calstripshit(4)
46			real calDSPtaberr(4), calevnum(4)
47	kusanagi	1.6	REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
48	kusanagi	1.7	real perror(4)
49			integer stwerr(4)
50	kusanagi	1.3
51	kusanagi	1.7	COMMON / evento / IEV, stwerr,perror,
52	kusanagi	1.3	& dexy,dexyc,base,
53			& calselftrig,calIItrig,
54			& calstripshit,calDSPtaberr,calevnum
55
56			save / evento /
57
58			COMMON / calib / IEV2, calped, calgood, calthr, calrms,
59			& calbase,
60			& calvar,
61			& calpuls
62
63			save / calib /
64
65	kusanagi	1.7	COMMON /VARIE/ error, CONTR, e2
66	kusanagi	1.3	SAVE /VARIE/
67
68
69			C
70			C Begin !
71			C
72	kusanagi	1.7	if (iev2.lt.0.or.iev2.gt.9000000) iev2 = 0
73	kusanagi	1.3	me = 0
74	kusanagi	1.7	lleng = 0
75	kusanagi	1.3	ic = 0
76	kusanagi	1.7	c
77			pari = 0
78			IF (MOD(LUNG,2).EQ.0) THEN
79			lunga = lung / 2
80			pari = 1
81			else
82			lunga = int(lung/2) + 1
83			endif
84			c
85			if (lunga.gt.30000) then
86			c print *,'Calorimeter WARNING: more than 30000 words!'
87			lunga = 30000
88			endif
89	kusanagi	1.3	c
90			length = ic
91			c
92			20 continue
93	kusanagi	1.6	ic = ic + length + 1
94	kusanagi	1.5	32 continue
95	kusanagi	1.3	ke = 0
96			do while (ke.eq.0)
97			C
98			C Check consistency of header.
99			C it is composed by CODE+D# (8 bits) and by SATUS WORD (8 bits)
100			c so we must split vect into the two components:
101			C
102			C ST1 is CODE + D#
103	kusanagi	1.6	c
104			st1b = 0
105			st2b = 0
106	kusanagi	1.7	if ((ic+3).gt.lung) then
107			error(contr) = 130
108			if (contr.ne.1) contr=5
109			me = 1
110			goto 200
111			endif
112	kusanagi	1.6	do bit = 0, 7
113			bi = ibits(vecta(ic),bit,1)
114			if (bi.eq.1) st1b = ibset(st1b,bit)
115			bi = ibits(vecta(ic+1),bit,1)
116			if (bi.eq.1) st2b = ibset(st2b,bit)
117			enddo
118			c
119	kusanagi	1.3	C ST2 is the STATUS WORD
120	kusanagi	1.6	c
121			length2 = 0
122			do bit=0, 7
123			bi = ibits(vecta(ic+3),bit,1)
124			if (bi.eq.1) length2 = ibset(length2,bit)
125			bi = ibits(vecta(ic+2),bit,1)
126			if (bi.eq.1) length2 = ibset(length2,bit+8)
127			enddo
128			c the crc should be at vect(length) with
129			length = length2 + 1
130			C
131			c some checks to be sure we have found the calorimeter data:
132			c
133			c status word is always less then 129
134			c
135			if (st2b.gt.128) then
136			length = 0
137			goto 100
138			endif
139			c
140			c length of the packet must be less then 20000 if no errors
141			c are found
142			c
143	kusanagi	1.7	if (st2b.eq.0.and.length2.gt.lunga) then
144	kusanagi	1.6	length = 0
145			goto 100
146			endif
147	kusanagi	1.3	c
148	kusanagi	1.6	if (length2.le.0) then
149			length = 0
150			goto 100
151			endif
152			c
153	kusanagi	1.3	e2(contr) = 0
154			C
155			if (contr.eq.1) then
156	kusanagi	1.6	c
157			c is it the first section?
158			c
159			if (st1b.eq.YE) then
160			c if so go out of this loop and go on recording data
161	kusanagi	1.3	ke = 1
162	kusanagi	1.6	m = ic
163	kusanagi	1.7	call riempi(m,lunga,lleng,lung,pari,vect,vecta)
164	kusanagi	1.6	icb = 1
165			if (st2b.ne.0) then
166			E2(contr) = vect(icb)
167	kusanagi	1.3	endif
168	kusanagi	1.6	goto 9
169	kusanagi	1.3	else
170	kusanagi	1.6	c if not, is it one of the next sections? did we miss a section?
171			if (st1b.eq.YO.or.st1b.eq.XE.or.st1b.eq.XO) THEN
172			c if so, record an error and go back analizing this section
173			error(contr) = 129
174			contr = 2
175			goto 32
176	kusanagi	1.3	ELSE
177	kusanagi	1.6	c if it is not the case, go on with the next value of vect
178			ERROR(contr) = 128
179	kusanagi	1.3	GOTO 100
180			endif
181			endif
182			ENDIF
183			C
184	kusanagi	1.6	c the same for the second section, ...
185			c
186			if (CONTR.eq.2) then
187			if (st1b.eq.YO) then
188	kusanagi	1.3	ke = 1
189	kusanagi	1.6	m = ic
190	kusanagi	1.7	call riempi(m,lunga,lleng,lung,pari,vect,vecta)
191	kusanagi	1.6	icb = 1
192			if (st2b.ne.0) then
193			E2(contr) = vect(icb)
194	kusanagi	1.3	endif
195	kusanagi	1.6	goto 9
196	kusanagi	1.3	else
197	kusanagi	1.6	if (st1b.eq.XE.or.st1b.eq.XO) then
198	kusanagi	1.3	error(contr) = 129
199			contr = 3
200	kusanagi	1.5	goto 32
201	kusanagi	1.3	ELSE
202			ERROR(contr) = 128
203			GOTO 100
204			endif
205			endif
206			ENDIF
207	kusanagi	1.6	c
208			C ... for the third,...
209			c
210	kusanagi	1.3	if (CONTR.eq.3) then
211	kusanagi	1.6	if (st1b.eq.XE) then
212	kusanagi	1.3	ke = 1
213	kusanagi	1.6	m = ic
214	kusanagi	1.7	call riempi(m,lunga,lleng,lung,pari,vect,vecta)
215	kusanagi	1.6	icb = 1
216			if (st2b.ne.0) then
217			E2(contr) = vect(icb)
218	kusanagi	1.3	endif
219	kusanagi	1.6	goto 9
220	kusanagi	1.3	else
221	kusanagi	1.6	if (st1b.eq.XO) then
222	kusanagi	1.3	error(contr) = 129
223			contr = 4
224	kusanagi	1.5	goto 32
225	kusanagi	1.3	ELSE
226	kusanagi	1.6	ERROR(contr) = 128
227	kusanagi	1.3	GOTO 100
228			endif
229			endif
230			ENDIF
231			C
232	kusanagi	1.6	c ...and for the last section.
233			c
234	kusanagi	1.3	if (CONTR.eq.4) then
235	kusanagi	1.6	if (st1b.eq.XO) then
236	kusanagi	1.3	ke = 1
237	kusanagi	1.6	m = ic
238	kusanagi	1.7	call riempi(m,lunga,lleng,lung,pari,vect,vecta)
239	kusanagi	1.6	icb = 1
240			if (st2b.ne.0) then
241			E2(contr) = vect(icb)
242	kusanagi	1.3	endif
243			else
244	kusanagi	1.6	c we should never arrive here (in case we run out of vector if section
245			c four is missing!)... however here it is in case of bugs!
246			c
247	kusanagi	1.3	ERROR(contr) = 128
248	kusanagi	1.6	goto 100
249	kusanagi	1.3	endif
250			endif
251			C
252			100 CONTINUE
253	kusanagi	1.6	c
254			c increment vector of one searching for the next section
255			c
256			9 continue
257	kusanagi	1.3	ic = ic + 1
258	kusanagi	1.6	c
259			c if we run out of vector give an error and exit the subroutine
260			c
261	kusanagi	1.7	if (ic.gt.(lung-1)) then
262	kusanagi	1.6	error(contr) = 130
263	kusanagi	1.3	if (contr.ne.1) contr=5
264			me = 1
265			goto 200
266			endif
267			enddo
268			C
269			10 FORMAT(2X,'Error for view:',2X,I1,2X,'Status word:',2X,Z4)
270			11 FORMAT(2X,'View or command not recognized for view:',2X,I1,2X,
271			& 'Status word:',2X,Z4)
272			12 FORMAT(2X,'Error - did NOT find view:',2X,I1)
273			13 FORMAT(2X,'Error - eof reached, exiting')
274			C
275			K = CONTR
276	kusanagi	1.6	ic0 = icb
277			ic = ic - 1
278			icb = icb + 1
279			length = vect(icb) + 2
280			length2 = vect(icb)
281	kusanagi	1.7	lleng = (length * 2) - 1
282	kusanagi	1.3	C
283			C Check validity of length.
284			C
285	kusanagi	1.6	if (vect(icb).ne.1057) then
286	kusanagi	1.3	ERROR(contr) = 131
287			me = 1
288			goto 200
289			endif
290			C
291			C Check consistency of CRC.
292			C
293			check = 0.
294			inf = ic0
295			sup = length - 1
296			do i = inf,sup
297			check=crc(check,vect(i))
298			enddo
299			if (check.ne.vect(length)) then
300			ERROR(contr) = 132
301			me = 1
302			goto 200
303			endif
304			C
305			C Process data.
306			C
307	kusanagi	1.6	if (k.eq.1) then
308			k = 4
309			goto 49
310			endif
311			if (k.eq.2) then
312			k = 2
313			goto 49
314			endif
315			if (k.eq.3) then
316			k = 1
317			goto 49
318			endif
319			if (k.eq.4) k = 3
320			c
321			49 continue
322			c
323	kusanagi	1.3	do j = 1,96
324			do i = 1,11
325			ic = ic + 1
326	kusanagi	1.6	if (k.eq.1) then
327			calpuls(k,i,97-j) = vect(icb)
328			else
329			calpuls(k,i,j) = vect(icb)
330			endif
331	kusanagi	1.3	enddo
332			enddo
333			CONTR = contr + 1
334			me = 0
335			c
336			if (contr.eq.5) contr = 1
337			c
338			50 continue
339			c
340			C
341			200 continue
342			C
343			if (error(1).eq.129.and.error(2).eq.129
344			& .and.error(3).eq.129.and.error(4).eq.130) then
345	kusanagi	1.5	call azero(error,4)
346	kusanagi	1.3	me = 1
347			contr=1
348			endif
349			C
350	kusanagi	1.7	do l = 1, 4
351			do bit=0, 31
352			if (bit.lt.16) then
353			bi = ibits(E2(L),bit,1)
354			else
355			bi = 0
356			endif
357			if (bi.eq.1) stwerr(l) = ibset(stwerr(l),bit)
358			enddo
359			perror(l) = float(error(l))
360			enddo
361			C
362			if (me.eq.0) iev2 = iev2 + 1
363	kusanagi	1.3	RETURN
364			END
365
366