forroutines/calorimeter/calpulse.for

C
C  Written by Mirko Boezio and Emiliano Mocchiutti
C
C     * Version: 3.0.0 *
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 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), calstriphit(4)
      real calDSPtaberr(4), calevnum(4)
      REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6)
      real perror(4), cperror(4)
      real pperror(4)
      integer pstwerr(4), IEV3
      integer cstwerr(4)
      integer stwerr(4), dump

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

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

      save / calib /

      COMMON / calpul / IEV3, pstwerr, pperror,
     &     calpuls

      save / calpul /

c

      COMMON /VARIE/ dump, CONTR
      SAVE /VARIE/
    

C         
C Begin !
C
      if (dump.eq.0) dump = -1
      if (iev3.lt.0.or.iev3.gt.9000000) iev3 = 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 fillin(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
c               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
c               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 fillin(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
c               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
c               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 fillin(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
c               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
c               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 fillin(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
c               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
c               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')
 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 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

      if (iev2.eq.dump) write(*,21)vect(length)
      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 (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
         if (l.eq.contr) then
            pperror(l) = float(error(l))
         else
            pperror(l) = 0.
         endif
      enddo
C
      if (me.eq.0) iev3 = iev3 + 1 
      RETURN
      END


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