forroutines/calorimeter/calpedestal.for

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
      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)

      COMMON / evento / IEV, 
     &     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
      ival = 0
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
         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
         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
               call riempi(m,lunga,lleng,lung,pari,vect,vecta)
               icb = 1
               if (st2b.ne.0) then
                  E2(contr) = vect(icb)
               endif
               goto 9
            else
c    if not, is it one of the next sections? did we miss a section?
              if (st1b.eq.YO.or.st1b.eq.XE.or.st1b.eq.XO) THEN
c     if so, record an error and go back analizing this section
                 error(contr) = 129
                 contr = 2
                 goto 32
               ELSE
c   if it is not the case, go on with the next value of vect
                  ERROR(contr) = 128  
                  GOTO 100
               endif
            endif
         ENDIF
C            
c     the same for the second section, ...
c
         if (CONTR.eq.2) then     
            if (st1b.eq.YO) then
               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
               goto 9
            else
               if (st1b.eq.XE.or.st1b.eq.XO) then
                  error(contr) = 129
                  contr = 3
                  goto 32
               ELSE
                  ERROR(contr) = 128
                  GOTO 100
               endif
            endif
         ENDIF
c
C     ... for the third,...
c
         if (CONTR.eq.3) then
            if (st1b.eq.XE) then
               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
               goto 9
            else
               if (st1b.eq.XO) then
                  error(contr) = 129
                  contr = 4
                  goto 32
               ELSE
                  ERROR(contr) = 128 
                  GOTO 100
               endif
            endif
         ENDIF
C
c     ...and for the last section.
c
         if (CONTR.eq.4) then
            if (st1b.eq.XO) then
               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
            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
               ERROR(contr) = 128
               goto 100
            endif  
         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
            error(contr) = 130
            if (contr.ne.1) contr=5
            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
         CONTR = CONTR + 1
         me = 0
c
         if (contr.eq.5) contr = 1
c
 50      continue
C
 200  continue
      if (error(1).eq.129.and.error(2).eq.129
     &     .and.error(3).eq.129.and.error(4).eq.130) then
         call azero(error,4)
         contr=1
         me = 1
      endif
C
      RETURN
      END


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