forroutines/calorimeter/calpedestal.for

C
C  Written by Mirko Boezio and Emiliano Mocchiutti
C
C     * Version: 2.17 *
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(30000) 
      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)

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