forroutines/calorimeter/calpedestal.for

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