forroutines/calorimeter/calpedestal.for

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