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


