C C Written by Mirko Boezio and Emiliano Mocchiutti C C * Version: 3.1.4 * C C 3.1.3 - 3.1.4: (2005-05-26) the decoding is wrong!!! we are reading all strip in one plane per time and not one strip over all planes per time!!!! C C 3.1.2 - 3.1.3: (2005-02-23) added some printout in debugging mode. C C 3.1.1 - 3.1.2: (2004-12-21) changed common varie. C C 3.1.0 - 3.1.1: (2004-12-13) bug in filling the calpuls vector. Fixed. C C 3.0.0 - 3.1.0: (2004-12-10) changes in the sections order and increment C iev each time calpulse is called. Cleanup of the code. C C 0.00.0 - 3.0.0: (2004-11-08) changes in the commons (one more common for C calpulse and from calstripshit to calstriphit). C C - fixed compilation error C C------------------------------------------------ SUBROUTINE CALPULSE(vecta,lung,me) C------------------------------------------------ IMPLICIT NONE C C Normal variables definition C INTEGER i, j, lung, me INTEGER NPLA, NCHA, LENSEV PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA) C INTEGER*2 VECT(60000) INTEGER*1 VECTA(lung) integer*2 check, crc,e2(4) INTEGER*2 length, length2 C INTEGER ERROR(4), merror(4) INTEGER ic, k, ke, ic0 INTEGER CONTR, m INTEGER inf, sup, lunga,lleng,l INTEGER XO, YO, XE, YE integer pstwerr(4), IEV integer dump integer st1b, st2b, bit,bi,icb, pari real pperror(4) REAL calpuls(4,11,96) 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 COMMON / calpul / iev, pstwerr, pperror, & calpuls save / calpul / c COMMON /VARIE/ dump, CONTR, merror SAVE /VARIE/ C C Begin ! C if (dump.eq.0) dump = -1 if (iev.lt.0.or.iev.gt.9000000) iev = 0 call clearall do i = 1, 4 pstwerr(i) = 0 pperror(i) = 0. error(i) = 0 e2(i) = 0 enddo me = 0 lleng = 0 ic = 0 c 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 30000 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 c is it the first section? c if (st1b.eq.XE.and.length2.eq.1057) then c if so go out of this loop and go on recording data ke = 1 m = ic contr = 1 if (iev.eq.dump) then print *,'1m,lunga,lleng,lung,pari',m,lunga,lleng,lung, & pari endif 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.1057) then contr = 2 ke = 1 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.1057) then contr = 3 ke = 1 m = ic 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.1057) 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 print *,'1 me = 1' call clearall do i = 1, 4 error(i) = 129 e2(i) = 0 pstwerr(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 - eof reached, exiting') 21 FORMAT(2X,'CRC: ',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 print *,'2 me = 1' me = 1 goto 200 endif if (iev.eq.dump) write(*,21)vect(length) if (iev.eq.dump) write(*,21)check c 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 do i = 1,11 do j = 1,96 icb = icb + 1 if (k.eq.1) then calpuls(k,i,97-j) = vect(icb) else calpuls(k,i,j) = vect(icb) endif enddo enddo print *,'3 me = 0' me = 0 c 50 continue c 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 (l.ne.contr) bi = 0 if (bi.eq.1) then pstwerr(l) = ibset(pstwerr(l),bit) else pstwerr(l) = ibclr(pstwerr(l),bit) endif enddo pperror(l) = float(error(l)) enddo C iev = iev + 1 RETURN END