forroutines/calorimeter/calpedestal.for

C
C  Written by Mirko Boezio and Emiliano Mocchiutti
C
C     * Version: 3.0.01 *
C 
C     3.0.00 - 3.0.01: (2004-11-08) changes in the commons (one more common for
C                     calpulse and from calstripshit to calstriphit). 
C 
C     previous - 3.0.00: (2004-10-25) cleanup, some small bugs fixed
C
C     - fixed compilation error
C
C------------------------------------------------
      SUBROUTINE CALPEDESTAL(vecta,lung,me)
C------------------------------------------------

      IMPLICIT NONE
C
C Normal variables definition
C
      integer lung
      INTEGER NPLA, NCHA, LENSEV
      PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
C
      INTEGER*1 VECTA(lung) 
      INTEGER*2 VECT(60000) 
C
      integer*2 check, crc, e2(4)
      INTEGER*2 length, length2
      integer*4 chksum, chksum2
C
      integer me, lleng
      INTEGER i, j, iev
      INTEGER ERROR(4)
      INTEGER ic, k, ke, ic0, l
      INTEGER contr, m
      INTEGER inf, sup,iev2
      INTEGER XO, YO, XE, YE
      integer st1b, st2b, bit, bi, icb
      INTEGER lunga, pari
      integer stwerr(4),dump, cstwerr(4)
      integer pstwerr(4),IEV3
C
      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 calpuls(4,11,96)
      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)
C
      DATA YE/182/ ! CODE_DSP_R YE = 101 10110
      DATA YO/173/ ! CODE_DSP_R YO = 101 01101
      DATA XE/170/ ! CODE_DSP_R XE = 101 01010
      DATA XO/177/ ! CODE_DSP_R XO = 101 10001
      
      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
C
C     DEBUG: PRINT OUT THE INPUT VECTOR
C
      if (iev2.eq.dump) then
         do l=1,lung
            write(*,17)l,vecta(l)
         enddo 
      endif
 17   FORMAT(2X,'Elemento:',2X,I6,2X,' word:',2X,Z8)
C     
      if (iev2.lt.0.or.iev2.gt.9000000) iev2 = 0
C     
      call clearall
      do i = 1, 4
         cstwerr(i) = 0
         cperror(i) = 0.
         error(i) = 0
         e2(i) = 0             
         stwerr(i) = 0
      enddo
      contr = 1
      me = 0
      lleng = 0
      ic = 0
      pari = 0
      length = 0
C
C     input length must be > 0, if not go out with error code 142
C
      if (lung.le.0) then
         if (dump.eq.iev) print *,'lung = ',lung      
         do i=1,4
            error(i)=142
         enddo
         goto 200
      endif
C
      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 60000 words!'
         lunga = 60000
      endif
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
c     is it the first section?
c     
         if (st1b.eq.YE.and.length2.eq.4629) then
c     if so go out of this loop and go on recording data
            ke = 1
            m = ic
            contr = 1
            call fillin(m,lunga,lleng,lung,pari,vect,vecta)
            icb = 1
            E2(contr) = vect(icb)                  
            goto 9
         endif
C            
c    the same for the second section, ...
c
         if (st1b.eq.YO.and.length2.eq.4629) then
            ke = 1                  
            contr = 2
            m = ic
            call fillin(m,lunga,lleng,lung,pari,vect,vecta)
            icb = 1
            E2(contr) = vect(icb)
            goto 9
         endif
c
C     ... for the third,...
c
         if (st1b.eq.XE.and.length2.eq.4629) then
            ke = 1
            m = ic
            contr = 3
            call fillin(m,lunga,lleng,lung,pari,vect,vecta)
            icb = 1
            E2(contr) = vect(icb)
            goto 9
         endif
C
c     ...and for the last section.
c
         if (st1b.eq.XO.and.length2.eq.4629) then
            contr = 4
            ke = 1
            m = ic
            call fillin(m,lunga,lleng,lung,pari,vect,vecta)
            icb = 1
            E2(contr) = vect(icb)
         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
            me = 1
            call clearall
            do i = 1, 4
               error(i) = 129            
               e2(i) = 0            
               stwerr(i) = 0
            enddo
            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 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
            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
         me = 0
c
c
 50      continue
C
 200  continue
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) then
               stwerr(l) = ibset(stwerr(l),bit)
            else
               stwerr(l) = ibclr(stwerr(l),bit)
            endif
         enddo
         perror(l) = float(error(l))
         cstwerr(l) = stwerr(l)
         cperror(l) = perror(l)
      enddo
C      
      iev2 = iev2 + 1
C
      RETURN
      END

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