C C Written by Mirko Boezio and Emiliano Mocchiutti C C * Version: 3.1.3 * 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.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