forroutines/calorimeter/calpedestal.for

C
C  Written by Mirko Boezio and Emiliano Mocchiutti
C
C     * Version: 2.18.2 *
C 
C     (see calunpack for changelog)
C
C     - fixed compilation error
C
C------------------------------------------------
      SUBROUTINE CALPEDESTAL(vecta,lung,me)
C------------------------------------------------

      IMPLICIT NONE
C
C Normal variables definition
C
      INTEGER ERROR(4)
C
      integer lung, me, lleng
      INTEGER i, j, ival, iev
      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,l
      INTEGER status,contr,m
      INTEGER inf, sup,iev2
      INTEGER XO, YO, XE, YE
      integer*4 chksum
      integer*4 chksum2, chksum1, chksum3


      INTEGER*2 length, length2
      integer st1b, st2b,p,bit,bi,icb
      INTEGER st1, st3
      INTEGER st2, lunga, llung, pari

      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)

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