forroutines/calorimeter/calpedestal.for

C
C  Written by Mirko Boezio and Emiliano Mocchiutti
C
C     * Version: 3.1.1 *
C
C     3.1.0 - 3.1.1: (2004-12-21) changed common varie.
C
C     3.0.01 - 3.1.0: (2004-12-10) cleanup of the code and changes in the 
C                     sections order.
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
      INTEGER ERROR(4), merror(4)
      INTEGER ic, k, ke, ic0, l
      INTEGER contr, m
      INTEGER inf, sup,iev
      INTEGER XO, YO, XE, YE
      integer st1b, st2b, bit, bi, icb
      INTEGER lunga, pari
      integer stwerr(4),dump, cstwerr(4)
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 perror(4), cperror(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 / calib / iev, cstwerr, cperror,
     &     calped, calgood, calthr, calrms, 
     &     calbase, calvar

      save / calib /
c
      COMMON /VARIE/ dump, contr, merror
      SAVE /VARIE/
    
C         
C Begin !
C
      if (dump.eq.0) dump = -1
C
C     DEBUG: PRINT OUT THE INPUT VECTOR
C
      if (iev.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 (iev.lt.0.or.iev.gt.9000000) iev = 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.XE.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.XO.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.YE.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.YO.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 (iev.eq.dump) write(*,21)vect(length)
      if (iev.eq.dump) write(*,21)check      
C
C Process data.
C
         if (k.eq.1) then
            k = 1
            goto 49
         endif
         if (k.eq.2) then
            k = 3
            goto 49
         endif
         if (k.eq.3) then
            k = 4
            goto 49 
         endif
         if (k.eq.4) k = 2
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      
      iev = iev + 1
C
      RETURN
      END

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