forroutines/calorimeter/calpulse.for

C
C  Written by Mirko Boezio and Emiliano Mocchiutti
C
C     * Version: 2.18.1 *
C 
C     (see calunpack for changelog)
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(60000)
      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), dump

      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, dump
      SAVE /VARIE/
    

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