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