forroutines/calorimeter/calpedestal.for

C
C  Written by Mirko Boezio and Emiliano Mocchiutti
C
C     * Version: 2.17.1 *
C 
C     (see calunpack for changelog)
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(60000) 
      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),dump

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