forroutines/calorimeter/calunpack.for

C
C  Written by Emiliano Mocchiutti and Mirko Boezio
C
C     * Version: 3.3.01 *
C
C Changelog:
C
C 3.3.00 - 3.3.01: (2004-10-18) forgot to clear stwerr if no sections are found
C                  fixed.
C
C 3.2.00 - 3.3.00: (2004-10-15) enanched search of sections in case of one or 
C                  more missing sections.
C                  Switched to c function "fillin" to create calorimeter words
C                  instead of fortran function "riempi": great improvement in 
C                  time processing!!
C
C 3.1.00 - 3.2.00: (2004-10-13) forget to clean some variables, fixed.
C                  Reprocess event in the case we have CRC errors and a high
C                  number of error trying to understand the kind of event
C                  we are processing (raw, compress, full mode) in order to 
C                  distinguish better the four section.The reprocessing happens
C                  on about the 30% of events with CRC errors (in the case of
C                  file 040827_005 the reprocessing is done on about 2% of all
C                  the events).
C
C 3.0.00 - 3.1.00: (2004-10-12) cleanup and speedup of the code, less loops
C                  same strength in finding the calorimeter sections.
C
C 2.18.4 - 3.0.00: (2004-10-07) major changes in the procedure to find the
C                  calorimeter sections and enhanced search in the case of 
c                  CRC errors (to fix a bug which made the misunderstanding 
C                  some kind of CRC errors with missing sections).
C                  Clean up unused variables, speeded up some loops.
C                  Zero length input vector error added.
C                  Enhanced search of the first section recorded since the 
C                  starting point is very important to correctly find and 
C                  interpret all the other sections.
C                  If section length is absurd and the CRC header bit = 0
C                  then search again for that section (needed to make a 
C                  better search of section when in presence of CRC errors)
C                  Search all the sections and if you reach the end of vector
C                  (EOV) continue searching if you haven't find all the four 
C                  section (and go out without looping if no section is 
C                  present).
C
C 2.18.3 - 2.18.4: consider a bad thing if you find a section in the wrong
C                  position of the vector and try again to 
C                  find the real data (if they exist).
C
C 2.18.2 - 2.18.3: vectors belonging to common must be cleared if the calo
C                  isn't found. Fixed.
C 
C 2.18.1 - 2.18.2: fixed unclearing error codes if the program doesn't find
C                  the calorimeter where it should be but shifted somewhere 
C                  else forgotten to clear st2c variable: fixed
C                  exit error code wrong in some cases: fixed
C                  self trigger data not saved: fixed.
C
C 2.18.0 - 2.18.1: small changes in the common varie to fix a memory leak;
C                  fixed an error in reporting error codes (stwerr,pwerror).
C
C 2.17.0 - 2.18.0: corrected bug which made unable the program to find CRC
C                  errors in the last section of the calorimeter;
C                  added a "debugging" option to dump to standard output
C                  the whole packet in hexadecimal format and other 
C                  useful informations. To activate it the dump variable
C                  in the common varie must be passed with the value
C                  of iev you want to check. Do nothing if you don't want
C                  any output.
C
C------------------------------------------------
      SUBROUTINE CALUNPACK(vecta,lung,me)
C------------------------------------------------

      IMPLICIT NONE
C
C     PARAMETERS DEFINITION
C
C     START = WHERE TO START TO LOOK FOR THE CALORIMETER, IN WORDS
C     1STSEC = MAXIMUM POSITION, IN BYTES, WHERE WE SUPPOSE TO FIND THE
C              HEADER OF THE FIRST SECTION 
C
      INTEGER START, SEC1ST
      INTEGER NPLA, NCHA, LENSEV
      INTEGER*2 ival
C
      PARAMETER (START=50,SEC1ST=1200)
      PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
      PARAMETER (ival='FFFF'x)
C
C Normal variables definition
C
      integer lung, SOGLIA0, SEC2ND
      INTEGER*1 VECTA(lung)
      INTEGER*2 vect(60000), test
      integer*2 check, crc, e2(4)
      INTEGER*2 length, length2
      integer me, m, dumpo, finoa
      INTEGER merror(4), headcor, ichc, coco
      INTEGER i, j, iev, min, st2c, bit, bi, lleng, salta
      INTEGER ic, k,l, ke, ic0, icsave, chi
      INTEGER hcchi(1000), hcic(1000),hcco
      INTEGER contr,  isfull, israw, iscomp
      INTEGER inf, sup, em, icb
      INTEGER XO, YO, XE, YE,iev2, icold
      integer st1b, st2b, lunga, pari
      integer stwerr(4),yescbra, chis, esci, icprima
      integer seemcomp, seemfull, cberaw, yesisco, yesisfu,yesisra
C     
      real dedx1(11,96),dedx2(11,96),dedx3(11,96),dedx4(11,96)
      real dedx1c(11,96),dedx2c(11,96),dedx3c(11,96),dedx4c(11,96)
      real base1(11,6),base2(11,6),base3(11,6),base4(11,6)
      REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6) 
      real auto(7)
      real calselftrig(4,7), calIItrig(4), calstripshit(4),
     &     calDSPtaberr(4), calevnum(4)
      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 calpuls(4,11,96)
      real perror(4)
C
      DATA XO/241/ ! CODE_EV_R XO = 111 10001
      DATA YO/237/ ! CODE_EV_R YO = 111 01101
      DATA XE/234/ ! CODE_EV_R XE = 111 01010
      DATA YE/246/ ! CODE_EV_R YE = 111 10110
C
      COMMON / evento / IEV, stwerr, perror,
     &     dexy,dexyc,base,
     &     calselftrig,calIItrig,
     &     calstripshit,calDSPtaberr,calevnum     
      save / evento /
C
      COMMON / calib / IEV2, calped, calgood, calthr, calrms, 
     &     calbase,
     &     calvar,
     &     calpuls
      save / calib /
C
      COMMON / VARIE / dumpo, CONTR
      SAVE / VARIE /   
C         
C Begin !
C
c      SOGLIA0 = 45
      SOGLIA0 = 70
C
C     input length must be > 0, if not go out with error code 142
C
      if (lung.eq.0) then
         if (dumpo.eq.iev) print *,'lung = ',lung      
         do i=1,4
            merror(i)=142
         enddo
         goto 999
      endif
C
C     no debug informations
C
      if (dumpo.eq.0) dumpo=-1
C
C     DEBUG: PRINT OUT THE INPUT VECTOR
C
      if (iev.eq.dumpo) then
         do l=1,lung
            write(*,17)l,vecta(l)
         enddo 
      endif
C
C     DETERMINE LENGTH IN WORDS FROM LENGTH IN BYTES
C
      IF (MOD(LUNG,2).EQ.0) THEN
         lunga = lung / 2
         pari = 1
      else
         lunga = int(lung/2) + 1
      endif
      SEC2ND = LUNGA
C
C     IS LENGTH IS TOO LONG?
C
      if (lunga.gt.60000.and.dumpo.gt.0) then
         print *,'Calorimeter WARNING: more than 60000 words!'
         lunga = 60000
      endif
C
C     PRE-CLEAR VARIABLES
C
      yesisco = 0
      yesisfu = 0
      yesisra = 0
      yescbra = 0
C
 1    CONTINUE
c    
C     CLEAR VARIABLES
C
      if (iev.lt.0.or.iev.gt.90000000) iev = 0
      esci = 0
      chi = 0
      chis = 0
      min = 0
      lleng = 0
      salta = 0
      m = 0
      pari = 0
      icb = 0
      em = 0
      coco = 0
      me = 1
      contr = 1
      ic = 1
      icsave = 0
C
      call canctutto
      call azero(dedx1,11*96)
      call azero(dedx2,11*96)
      call azero(dedx3,11*96)
      call azero(dedx4,11*96)
      call azero(dedx1c,11*96)
      call azero(dedx2c,11*96)
      call azero(dedx3c,11*96)
      call azero(dedx4c,11*96)
      call azero(base1,11*6)
      call azero(base2,11*6)
      call azero(base3,11*6)
      call azero(base4,11*6)
C
      do l = 1,4
         e2(l) = 0
         perror(l) = 0.
         stwerr(l) = 0
         merror(l) = 0
      enddo
C
C     DETERMINE WHERE TO START TO FIND THE CALORIMETER IN THE INBUT BUFFER
C 
      length2 = start      
c
 20   continue      
C
      if (length2.ge.-2) then
         ic = ic + (2 * (length2 + 2)) 
      else
         if (dumpo.gt.0)
     &    print *,'Calorimeter WARNING: length errors ',ic,length2
      endif
C
      headcor = 0
      ichc = ic
      icprima = ic
      hcco = 0
      do i=1,1000
         hcchi(i) = 0
         hcic(i) = 0
      enddo
c
 32   continue
C
      ke = 0
      chis = chi
      icold = ic
      do while (ke.eq.0) 
C
C         if (iev.eq.dumpo) print *,'parto da ',ic,contr
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
         st1b = 0
         st2b = 0
C     
C     A CALORIMETER SECTION IS MADE OF AT LEAST 4 BYTES
C     IF WE HAVE NO ROOM FOR A SECTION GO OUT
C
         if ((ic+4).gt.lung.or.esci.eq.1) then 
            if (headcor.eq.1.and.contr.lt.5) then               
               headcor=-1
               ic=ichc
               goto 32
            else
               if (headcor.eq.0.or.headcor.eq.2) then
                  chi = chi + 8 * (5 - contr)
               endif
               merror(contr) = 129               
               if (iev.eq.dumpo) print *,'azzera qua ',headcor
               if (esci.eq.0) then
                  ic = icsave
               else
                  ic = icprima
               endif
               if (headcor.eq.2) then
                  chi = chis
               endif
               esci = 0
               headcor = 0
               hcco = 0
               ichc = 0
               do i=1,1000
                  hcchi(i) = 0
                  hcic(i) = 0
               enddo
               length2 = -2
               lleng = 0
               length = 0
               goto 150
            endif
         endif
C
C     ST1B IS "CODE", ST2B IS "D#"
C
         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     IC+2 AND IC+3 CONTAINS THE LENGTH OF THE CALORIMETER SECTION
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
c     the crc should be at vect(length) with
C
         length = length2 + 1 
C
c     some checks to be sure we have found the calorimeter data:     
c     status word is always less then 129
c
         if (st2b.gt.128) then
            length = 0
            length2 = 0
            goto 100
         endif
c
c     length of the packet IN WORDS must be less then HALF OF THE
C     LENGTH IN BYTES  if noT THERE ARE SOME errors 
c
         bi = ibits(st2b,0,1)
         if (length2.gt.lunga.OR.LENGTH2.LE.0) then
            if (headcor.eq.2) then
               chi = chi + 4
            endif
            length = 0
            length2 = 0
            goto 100
         endif
c
         e2(contr) = 0
C
         if (CONTR.eq.1) then
c
c     is it the first section?
c
            if (st1b.eq.YE) then
c     if so go out of this loop and go on recording data
               ke = 1
               icsave = ic
               m = ic               
               call fillin(m,lunga,lleng,lung,pari,vect,vecta) 
C              
               icb = 1
               E2(contr) = vect(icb)
               if (headcor.eq.2) then
                  if (coco.ne.1) then
                     coco = 1
                  else
                     coco = -1
                  endif
                  if (st2b.ne.0) then
                     call contaer(e2(contr),chi)
                  endif
               endif
               goto 100
            endif
         ENDIF
C            
c     the same for the second section, ...
c
         if (CONTR.eq.2) then     
            if (st1b.eq.YO) then
               ke = 2             
               icsave = ic
               m = ic
               call fillin(m,lunga,lleng,lung,pari,vect,vecta) 
               icb = 1
               E2(contr) = vect(icb)
               if (headcor.eq.2) then
                  if (coco.ne.2) then
                     coco = 2
                  else
                     coco = -1
                  endif
                  if ((ic-icold).ne.0) chi=chi+abs(ic-icold)             
                  if (st2b.ne.0) then
                     call contaer(e2(contr),chi)
                  endif
               endif
               goto 100
            endif
         ENDIF
c
C     ... for the third,...
c
         if (CONTR.eq.3) then
            if (st1b.eq.XE) then
               ke = 3
               icsave = ic
               m = ic
               if (iev.eq.dumpo) then
                  print *,'m,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)
               if (iev.eq.dumpo) then
                  print *,'headcor ',headcor
                  write(*,22)vect(icb)
                  print *,'m,lunga,lleng,lung,pari',m,lunga,lleng,lung,
     &                 pari
               endif
               if (headcor.eq.2) then                  
                  if (coco.eq.3) then
                     coco = 3
                  else
                     coco = -1
                  endif
                  if (ic-icold.ne.0) chi = chi + abs(ic-icold)
                  if (st2b.ne.0) then
                     call contaer(e2(contr),chi)
                  endif
               endif
               goto 100
            endif
         ENDIF
C
c     ...and for the last section.
c
         if (CONTR.eq.4) then
            if (st1b.eq.XO) then
               ke = 4
               icsave = ic
               m = ic
               call fillin(m,lunga,lleng,lung,pari,vect,vecta) 
               icb = 1
               E2(contr) = vect(icb)
               if (headcor.eq.2) then
                  if (coco.eq.4) then
                     coco = 4
                  else
                     coco = -1
                  endif
                  if ((ic-icold).ne.0) chi = chi + abs(ic-icold)
                  if (st2b.ne.0) then
                     call contaer(e2(contr),chi)
                  endif
               endif
               goto 100
            endif  
         endif
C
         if (contr.gt.4) then
            if (iev.eq.dumpo) print *,'esci qua'
            headcor = 0
            hcco = 0
            ichc = 0
            do i=1,1000
               hcchi(i) = 0
               hcic(i) = 0
            enddo
            goto 200
         endif
C     
 100     CONTINUE
c
c     increment vector of one searching for the next section
c
         ic = ic + 1 
c
      enddo
C              
c     format not used
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')
 14   FORMAT(2X,I8,2X,I10)
 15   FORMAT(2X,I8,2X,Z8)
 17   FORMAT(2X,'Elemento:',2X,I6,2X,' word:',2X,Z8)
 18   FORMAT(2X,'Elemento:',2X,I6,2X,' word:',2X,Z2,Z2)
 21   FORMAT(2X,'CRC: ',2X,Z8)
 22   FORMAT(2X,'vect(icb): ',2X,Z8)
C
c     go on recording data
      ic = ic - 1
c
c     
      K = CONTR
      ic0 = icb
      icb = icb + 1
      length = vect(icb) + 2 
      length2 = vect(icb)    
      lleng = (length*2) - 1
C
C Check consistency of CRCs.
C
C
C     IF THE STATUS WORD HAS THE CRC BIT ON AND WE ARE NOT IN THE
C     HEADCOR CASE 0 (WE WERE BELIEVING THE SECTION FOUND WAS FINE)
C
      if ((ibits(e2(contr),0,1).ne.0.or.
     &    (ibits(e2(contr),3,1).eq.1.and.length2.ne.1064))
     &    .and.headcor.EQ.0) then 
         headcor = 1
         ichc = ic - 1
         if (iev.eq.dumpo) print *,'crc st word wrong',ic,ichc,headcor
      endif
C
C     HEADOCR = 1 MEANS SEARCH AGAIN FOR THAT SECTION
C
      if (headcor.eq.1) then
         hcco = hcco + 1
         if (st2b.ne.0) then
            call contaer(e2(contr),hcchi(hcco))
         endif         
C         
         if (contr.gt.1.or.yesisco.ne.0.or.yesisfu.ne.0
     &        .or.yesisra.ne.0.or.yescbra.ne.0) then
            iscomp = 0
            isfull = 0
            israw = 0
            if (yesisco.ne.0.or.yesisfu.ne.0
     &           .or.yesisra.ne.0.or.yescbra.ne.0) then
               if (yesisra.ne.0.or.yescbra.ne.0) israw = 2
               if (yesisco.ne.0) iscomp = 2
               if (yesisfu.ne.0) isfull = 2
            else
               i = 1
               do while(iscomp.eq.0.and.isfull.eq.0.and.israw.eq.0.and.
     &              i.lt.(contr-1))
                  if (ibits(stwerr(i),16,1).eq.1) iscomp = iscomp + 1
                  if (ibits(stwerr(i),17,1).eq.1) isfull = isfull + 1
                  if (ibits(e2(i),3,1).eq.1.and.merror(i).eq.0) 
     &                 israw = israw + 1         
                  i = i + 1
               enddo
            endif
c     
c     how does this section look like? (note that in case of crc errors
c     this test has no value...)
c
            test = vect(icb+10)
            seemcomp = 0
            seemfull = 0
            if (test.eq.ival) then
               seemcomp = 1
            elseif (test.eq.0) then
               seemfull = 1
            endif
c
c     if a previous good section was raw and this header we are analyzing
c     is not raw something strange is happening, add a weight.
c
            if ((israw.ne.0.and.ibits(e2(contr),3,1).ne.1)
     &           .or.(israw.ne.0.and.length2.ne.1064)) then
               hcco = hcco - 1
               length=0
               length2=0
               lleng=0
               ic = ic + 1
               if (iev.eq.dumpo) 
     &              print *,'not raw, search again ',ic,ichc,headcor
               goto 32  
            endif
c            if (israw.ne.0.and.ibits(e2(contr),3,1).ne.1)
c     &           hcchi(hcco) = hcchi(hcco) + 2

c            if (israw.ne.0.and.length2.ne.1064)
c     &           hcchi(hcco) = hcchi(hcco) + 2


c
c     the same with compress and full mode
c
            if ((iscomp.ne.0.or.isfull.ne.0)
     &       .and.ibits(e2(contr),3,1).eq.1) then
               hcco = hcco - 1
               length=0
               length2=0
               lleng=0
               ic = ic + 1
               if (iev.eq.dumpo) 
     &   print *,'raw in full or compress mode, search again ',ic,ichc,
     &              headcor
               goto 32  
            endif

            if (iscomp.ne.0.and.(ibits(e2(contr),3,1).eq.1.or.
     &           seemcomp.eq.0)) hcchi(hcco) = hcchi(hcco) + 2
            if (isfull.ne.0.and.(ibits(e2(contr),3,1).eq.1.or.
     &           seemfull.eq.0)) hcchi(hcco) = hcchi(hcco) + 2
         endif
C     
         if (ibits(e2(contr),3,1).eq.1.and.length2.eq.1064) then
            hcchi(hcco) = hcchi(hcco) - 2
         elseif ((ibits(e2(contr),3,1).eq.1.or.israw.ne.0)
     &           .and.length2.ne.1064) then
            hcco = hcco - 1
            length=0
            length2=0
            lleng=0
            ic = ic + 1
            if (iev.eq.dumpo) 
     & print *,'raw bit not raw length, search again ',ic,ichc,headcor
            goto 32  
         endif
C
         hcic(hcco) = ic
         ic = ic + 1
         length=0
         length2=0
         lleng=0
         if (iev.eq.dumpo) print *,'search again ',ic,ichc,headcor         
         goto 32         
      endif
C     
C     HEADCOR = - 1 MEANS STOP SEARCHING FOR THAT SECTION, SELECT
C     THE CASE WITH LESS ERRORS, FOUND THAT SECTION AND GIVE
C     HEADCOR = 2 (I.E. GO OUT OF THE LOOP)
C
      if (headcor.eq.-1) then
         if (iev.eq.dumpo) print *,'entro in -1, ',hcco,ke
         headcor = 2
         if (ke.le.2.and.hcco.ge.1) then
            finoa = 0
            do i = 1, hcco
               if (ke.eq.1.and.hcic(i).lt.SEC1ST) finoa = i
               if (ke.eq.2.and.hcic(i).lt.SEC2ND) finoa = i
            enddo
            if (finoa.eq.0) then
c               IC = LUNG               
               esci = 1
               if (iev.eq.dumpo)
     &              print *,'finoa=0! no possible solutions '
            else
               if (iev.eq.dumpo) print *,'ke = ',ke,' and hcco>1 ',finoa      
               call minerr(ic,hcic,hcchi,min,finoa)
            endif
         else
            if (hcco.eq.0) then
c               IC = LUNG
               esci = 1 
               if (iev.eq.dumpo) 
     &              print *,'hcco=0! no possible solutions'
            else               
               call minerr(ic,hcic,hcchi,min,hcco)
            endif
         endif
         e2(contr) = 0
         if (iev.eq.dumpo) then
            print *,'stop searching'
            print *,'ic,hcic(min),min,... ',ic,hcic(min),min,
     &           hcchi(min),hcco,coco
            do i=1,hcco
               print *,'i, hcchi ',i,hcchi(i)
            enddo
         endif
c
c         if (hcchi(min).gt.8) then 
c            IC = LUNG
c         endif
c
         length=0
         length2=0
         lleng=0
         goto 32
      endif
C
C     determine the type of data if not raw (compress or full)
C
      if (headcor.eq.0.or.headcor.eq.2
     &     .and.ibits(e2(contr),3,1).ne.1) then
         test = vect(icb+10)
         seemcomp = 0
         seemfull = 0
         if (test.eq.ival) then
C     compress mode
            stwerr(contr) = ibset(stwerr(contr),16)
         elseif (test.eq.0) then
C
            stwerr(contr) = ibset(stwerr(contr),17)
         endif        
      endif
C
      hcco = 0
      ichc = 0
      check = 0
      do i=1,1000
         hcchi(i) = 0
         hcic(i) = 0
      enddo
      inf = ic0
      sup = length - 1
      do i = inf,sup
         check=crc(check,vect(i))
      enddo
C
      if (iev.eq.dumpo) write(*,21)vect(length)
      if (iev.eq.dumpo) write(*,21)check      
C
      if (check.ne.vect(length)) then
         merror(contr) = 132
         chi = chi + 4
         lleng = 0
         length2 = 0
         length = 0
         if (ke.eq.1.and.headcor.ne.2) then
            ic = 10
         elseif (headcor.eq.2) then
            contr = contr + 1            
         endif
         headcor = 1
         ichc = ic - 1
         if (iev.eq.dumpo)
     &        print *,'crc sbagliato ',ic,
     &        ' cerca la sezione ',contr,' coco = ',coco
         goto 32     
      else
         chi = chi - 4
         if (chi.lt.0) chi = 0
      endif
C
      headcor = 0
C
 19   CONTINUE
C     
C     Process data.
C     
      do i = 1, 7 
         icb = icb + 1
         auto(i) = vect(icb)
      enddo
C     
      st2c = 0
      if (st2b.ne.0) then
         do bit=0, 6
            bi = ibits(st2b,bit,1)
            if (bit.eq.3.and.bi.ne.0) st2c = 8
         enddo
      endif
C     
      if (st2c.eq.8) then
         if (length2.ne.1064) then
            merror(contr) = 133
            chi = chi + 4
            if (iev.eq.dumpo) 
     &           print *,'raw lung 4'
            lleng = 0
            goto 150
         else               
            if (k.eq.1) then
               call azero(dedx1,11*96)
               call azero(dedx2,11*96)
               call azero(dedx3,11*96)
               call azero(dedx4,11*96)
               call azero(dedx1c,11*96)
               call azero(dedx2c,11*96)
               call azero(dedx3c,11*96)
               call azero(dedx4c,11*96)
               call azero(base1,11*6)
               call azero(base2,11*6)
               call azero(base3,11*6)
               call azero(base4,11*6)
               call CALRAW(vect,icb+1,length-1,dedx1)
            endif
            if (k.eq.2) call CALRAW(vect,icb+1,length-1,dedx2)
            if (k.eq.3) call CALRAW(vect,icb+1,length-1,dedx3)
            if (k.eq.4) call CALRAW(vect,icb+1,length-1,dedx4)
         endif
         goto 50
      endif
C     
 41   FORMAT(2X,I2,2X,'word :',1x,z4)
      test = vect(icb+3)
c     
      if (test.eq.ival) then
         if (length2.gt.1201) then
            merror(contr) = 134
            chi = chi + 4
            if (iev.eq.dumpo) 
     &           print *,'compr lung 4'
            lleng = 0
            goto 150
         else
            icb = icb + 1
            calIItrig(k) = vect(icb)
            icb = icb + 1
            calstripshit(k) = vect(icb)
            icb = icb + 1
C     qui c'e` test!
            icb = icb + 1
            calDSPtaberr(k) = vect(icb)
            icb = icb + 1
            calevnum(k) = vect(icb)
c            merror(contr) = 137
            if (k.eq.1) then
               call azero(dedx1,11*96)
               call azero(dedx2,11*96)
               call azero(dedx3,11*96)
               call azero(dedx4,11*96)
               call azero(dedx1c,11*96)
               call azero(dedx2c,11*96)
               call azero(dedx3c,11*96)
               call azero(dedx4c,11*96)
               call azero(base1,11*6)
               call azero(base2,11*6)
               call azero(base3,11*6)
               call azero(base4,11*6)
               call CALCOMPRESS(vect,icb+1,length-1,dedx1c,
     &              base1)
            endif
            if (k.eq.2) call CALCOMPRESS(vect,icb+1,length-1,dedx2c,
     &           base2)
            if (k.eq.3) call CALCOMPRESS(vect,icb+1,length-1,dedx3c,
     &           base3)
            if (k.eq.4) call CALCOMPRESS(vect,icb+1,length-1,dedx4c,
     &           base4)
            goto 50
         endif
      else if (test.eq.0) then
         if (length2.gt.2257) then
            merror(contr) = 135
            chi = chi + 4
            if (iev.eq.dumpo) 
     &           print *,'full lung 4'
            lleng = 0
            goto 150
         else
            icb = icb + 1
            calIItrig(k) = vect(icb)
            icb = icb + 1
            calstripshit(k) = vect(icb)
            icb = icb + 1
C     qui c'e` test
            icb = icb + 1
            calDSPtaberr(k) = vect(icb)
            icb = icb + 1
            calevnum(k) = vect(icb)
c            merror(contr) = 138
            if (k.eq.1) then 
               call azero(dedx1,11*96)
               call azero(dedx2,11*96)
               call azero(dedx3,11*96)
               call azero(dedx4,11*96)
               call azero(dedx1c,11*96)
               call azero(dedx2c,11*96)
               call azero(dedx3c,11*96)
               call azero(dedx4c,11*96)
               call azero(base1,11*6)
               call azero(base2,11*6)
               call azero(base3,11*6)
               call azero(base4,11*6)
               call CALFULL(vect,icb+1,length-1,dedx1,
     &              dedx1c,base1)
            endif
            if (k.eq.2) call CALFULL(vect,icb+1,length-1,dedx2,
     &           dedx2c,base2)
            if (k.eq.3) call CALFULL(vect,icb+1,length-1,dedx3,
     &           dedx3c,base3)
            if (k.eq.4) call CALFULL(vect,icb+1,length-1,dedx4,
     &           dedx4c,base4)
            goto 50
         endif
      else
         merror(contr) = 136
         chi = chi + 4
         if (iev.eq.dumpo) 
     &        print *,'decoding problems 4'
         lleng = 0
         goto 150
      endif
c     
 50   continue
c     
C     
      do i = 1,7
         calselftrig(k,i) = auto(i) 
      enddo
C     
      DO I = 1,11
         DO J = 1,96
            DEXY(2,2*I-1,97-J) = DEDX3(I,J)
            DEXY(1,2*I-1,J) = DEDX2(I,J)
            DEXY(2,2*I,J) = DEDX4(I,J)
            DEXY(1,2*I,J) = DEDX1(I,J)
            DEXYC(2,2*I-1,97-J) = DEDX3C(I,J)
            DEXYC(1,2*I-1,J) = DEDX2C(I,J)
            DEXYC(2,2*I,J) = DEDX4C(I,J)
            DEXYC(1,2*I,J) = DEDX1C(I,J)
         enddo
         do j = 1,6
            base(2,2*i-1,7-j) = base3(i,j)
            base(1,2*i-1,j) = base2(i,j)
            base(2,2*i,j) = base4(i,j)
            base(1,2*i,j) = base1(i,j)
         enddo
      enddo
C
 150  continue
C
      contr = contr + 1
C
c     go on till we have found all the four sections
c
      if (contr.lt.5) goto 20
c
 200  continue
C
      iscomp = 0
      isfull = 0
      israw = 0
      do i = 1, 4
         if (ibits(stwerr(i),16,1).eq.1) iscomp = iscomp + 1
         if (ibits(stwerr(i),17,1).eq.1) isfull = isfull + 1
         if (ibits(e2(i),3,1).eq.1) israw = israw + 1         
      enddo
      if (iscomp.ne.0) chi = chi + 8 * (4 - iscomp)
      if (israw.ne.0) chi = chi + 8 * (4 - israw)
      if (isfull.ne.0) chi = chi + 8 * (4 - isfull)
C
C     if chi>10 and we have information enough to understand the physic event
C     was acquired in a certain mode (RAW, FULL or COMPRESS) then reprocess
C     the event using this information, sometimes we miss a section due to 
C     CRC errors in the previous one but if we know what we are looking for
C     then it is possible to save this kind of events.
C
      if (chi.gt.5.and.yesisco.eq.0.and.yesisfu.eq.0
     &     .and.yesisra.eq.0.and.yescbra.eq.0) then
         israw = 0
         cberaw = 0
         do i = 1, 4
            if (ibits(e2(i),3,1).eq.1.and.merror(i).eq.0) 
     &           israw = israw + 1         
            if (ibits(e2(i),3,1).eq.1.and.merror(i).eq.132) 
     &           cberaw = cberaw + 1         
         enddo
         yesisco = 0
         yesisfu = 0
         yesisra = 0
         yescbra = 0
         if (iscomp.ne.0) yesisco = 1
         if (isfull.ne.0) yesisfu = 1
         if (israw.ne.0) yesisra = 1
         if (cberaw.ne.0) yescbra = 1
         if ((yesisco+yesisfu+yesisra).eq.1.or.
     &        ((yesisco+yesisfu+yesisra).eq.0.and.yescbra.eq.1)) then
            if (iev.eq.dumpo) then
               print *,'************************'
               if (iscomp.ne.0) print *,'is a compress acq.'
               if (isfull.ne.0) print *,'is a full acq.'
               if (israw.ne.0) print *,'is a raw acq.'
               if (israw.eq.0.and.cberaw.ne.0) 
     &              print *,'could be a raw acq.'
               print *,'so, SGARBUF, do it again! ',chi
               print *,'************************'
            endif
            SOGLIA0 = SOGLIA0 - ISCOMP - ISFULL - ISRAW
            goto 1
         endif
         if ((yesisco+yesisfu+yesisra+yescbra).eq.0) chi = 1000
      endif
C
      if (iev.eq.dumpo)
     &     print *,'chi <= soglia0 ?',chi,soglia0
      if (chi.lt.soglia0) then
         me = 0
      else
         me = 1
         do i = 1, 4
            merror(i) = 129            
            e2(i) = 0            
            stwerr(i) = 0.
         enddo
         call canctutto
         goto 999
      endif
C
C     if all section are missing clear vectors and go out
C
      if (merror(1).eq.129.and.merror(2).eq.129
     &     .and.merror(3).eq.129.and.merror(4).eq.129) then
         do l = 1,4
            e2(l) = 0
            stwerr(l) = 0
         enddo
         call canctutto
      endif
c
 999  continue
c
      do l = 1, 4
         do bit=0, 31
            if (bit.lt.16) then
               bi = ibits(E2(L),bit,1)
            elseif (bit.gt.17) then
               bi = 0
            elseif (bit.ge.16.and.bit.le.17) then
               bi = 2
            endif
            if (bi.eq.1) then
               stwerr(l) = ibset(stwerr(l),bit)
            elseif (bi.eq.0) then
               stwerr(l) = ibclr(stwerr(l),bit)
            endif
         enddo
         perror(l) = float(merror(l))
      enddo
c
      iev = iev + 1
      RETURN
      END


C------------------------------------------------
      SUBROUTINE CALRAW(vect,inf,sup,dedx)
C------------------------------------------------

      IMPLICIT NONE
C
      INTEGER NPLA, NCHA, LENSEV
      PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
C
      INTEGER*2 VECT(30000) 
      INTEGER inf, sup
      INTEGER i,j,k, iev,iev2
      INTEGER contr
      integer stwerr(4), dumpo
C
      REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6) 
      real calselftrig(4,7), calIItrig(4), calstripshit(4),
     &     calDSPtaberr(4), calevnum(4)
      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 calpuls(4,11,96)
      REAL dedx(11,96)
      real perror(4)
C
      COMMON / evento / IEV, stwerr, perror,
     &     dexy,dexyc,base,
     &     calselftrig,calIItrig,
     &     calstripshit,calDSPtaberr,calevnum
      
      save / evento /

      COMMON / calib / IEV2, calped, calgood, calthr, calrms, 
     &     calbase,
     &     calvar,
     &     calpuls

      save / calib /
c
      COMMON / VARIE / dumpo, CONTR
      SAVE / VARIE /
c
      k = inf
      do j = 1,96
         do i = 1,11
            DEDX(I,J) = 0.
            dedx(i,j) = vect(k)
            k = k + 1
         enddo
      enddo
c
      RETURN
      END

C------------------------------------------------
      SUBROUTINE CALCOMPRESS(vect,inf,sup,dedx,basse)
C------------------------------------------------

      IMPLICIT NONE

      INTEGER NPLA, NCHA, LENSEV
      PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
C
      INTEGER*2 VECT(30000) 
      INTEGER*2 st, st1, st2
      INTEGER inf, sup
      INTEGER i,j, iev,iev2
      INTEGER ib
      INTEGER ipl, ipr, ist
      INTEGER merror(4)
      INTEGER contr
      integer stwerr(4),dumpo
C
      REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6) 
      real calselftrig(4,7), calIItrig(4), calstripshit(4),
     &     calDSPtaberr(4), calevnum(4)
      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 calpuls(4,11,96)
      REAL dedx(11,96), basse(11,6)
      real perror(4)
C
      COMMON / evento / IEV, stwerr,perror,
     &     dexy,dexyc,base,
     &     calselftrig,calIItrig,
     &     calstripshit,calDSPtaberr,calevnum
      
      save / evento /

      COMMON / calib / IEV2, calped, calgood, calthr, calrms, 
     &     calbase,
     &     calvar,
     &     calpuls

      save / calib /
c
      COMMON / VARIE / dumpo, CONTR
      SAVE / VARIE /
    
C
      DO I = 1,11
         DO J = 1,96
            if (j.le.6) basse(i,j) = 0.
            DEDX(I,J) = 0.
         ENDDO
      ENDDO
C
      i = inf
c
 10   continue
      if (i.gt.sup) then
         RETURN
      endif
C
 40   format(2x,i5,2x,'status :',1x,Z4)
C
c
      st1 = 0
      st1 = IAND(vect(i),'0800'x)
      st1 = ISHFT(st1,-11)
 43      format(2x,'vect(i)  = ',Z8)
      if (st1.eq.1) then
         ib = 1
      else
         st2 = IAND(vect(i),'1000'x) 
         st2 = ISHFT(st2,-12) 
         if (st2.eq.1) then 
            ib = 0
         else
            if (iev.eq.dumpo) then
               print *,'i ',i
               write(*,43)vect(i)
            endif
            merror(contr) = 139
            RETURN
         endif
      endif
C
      if (ib.eq.1) then
C     
         st = IAND(vect(i),'00FF'x)
c
         ipl = int(st/6) + 1
         ipr = st - (ipl - 1) * 6 + 1
         i = i + 1
         if (i.gt.sup) RETURN
         basse(ipl,ipr) = vect(i)
c         
 20      continue
         if (i.gt.sup) RETURN
C
         i = i + 1
         if (i.gt.sup) RETURN
         if ((vect(i)+1).gt.16.or.(vect(i)+1).lt.1) then
            goto 10
         endif
         ist = vect(i) + 1 + 16 * (ipr - 1)
         i = i + 1
         if (i.gt.sup) RETURN
         dedx(ipl,ist) = vect(i)
         goto 20
      else
C
         st = IAND(vect(i),'00FF'x)
         ipl = int(st/6) + 1 
         ipr = st - (ipl - 1) * 6 + 1
         do j = 1,16
            i = i + 1
            if (i.gt.sup) RETURN
            ist = j + 16 * (ipr - 1)
            dedx(ipl,ist) = vect(i)
         enddo
         i = i + 1
         if (i.gt.sup) RETURN
         goto 10
C         
      endif


      RETURN
      END


C----------------------------------------------------------
      SUBROUTINE CALFULL(vect,inf,sup,dedx,dedxc,basse)
C--------------------------------------------------------------

      IMPLICIT NONE

      INTEGER NPLA, NCHA, LENSEV
      PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
C
      INTEGER*2 VECT(30000) 
      INTEGER inf, sup
      INTEGER i,j,k, iev,iev2
      INTEGER contr
      integer stwerr(4),dumpo
C
      REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6) 
      real calselftrig(4,7), calIItrig(4), calstripshit(4),
     &     calDSPtaberr(4), calevnum(4)
      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 calpuls(4,11,96)
      REAL dedx(11,96), basse(11,6), dedxc(11,96)
      real perror(4)
C
      COMMON / evento / IEV, stwerr,perror,
     &     dexy,dexyc,base,
     &     calselftrig,calIItrig,
     &     calstripshit,calDSPtaberr,calevnum
      
      save / evento /

      COMMON / calib / IEV2, calped, calgood, calthr, calrms, 
     &     calbase,
     &     calvar,
     &     calpuls

      save / calib /

c
      COMMON / VARIE / dumpo, CONTR
      SAVE / VARIE /
C
      k = inf     
      do i = 1,11
         do j = 1,96
            DEDX(I,J) = 0.
            dedx(i,j) = vect(k)
            k = k + 1
         enddo
      enddo
C
      call CALCOMPRESS(vect,k,sup,dedxc,basse)
C
 10   FORMAT(2X,'Status word:',2X,Z8)      

      RETURN
      END


C------------------------------------------------
      SUBROUTINE CONTAER(ve,er)
C------------------------------------------------

      IMPLICIT NONE

      INTEGER NPLA, NCHA, LENSEV
      PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
C
      INTEGER*2 VE, st4
      INTEGER er, bit, bi, iev,iev2
      INTEGER contr
      integer stwerr(4),dumpo
C
      REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6) 
      real calselftrig(4,7), calIItrig(4), calstripshit(4),
     &     calDSPtaberr(4), calevnum(4)      
      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 calpuls(4,11,96)
      real perror(4)
C
      COMMON / evento / IEV, stwerr,perror,
     &     dexy,dexyc,base,
     &     calselftrig,calIItrig,
     &     calstripshit,calDSPtaberr,calevnum
      
      save / evento /

      COMMON / calib / IEV2, calped, calgood, calthr, calrms, 
     &     calbase,
     &     calvar,
     &     calpuls

      save / calib /

      COMMON / VARIE / dumpo, CONTR
      SAVE / VARIE /
    
                 
      st4 = 0
      st4 = IAND(ve,'00FF'x)
      if (st4.ne.0) then
         do bit=0, 6
            bi = ibits(st4,bit,1)
            if (bi.ne.0) then
               er = er + 2
            endif
         enddo
      endif
      
 10   FORMAT(2X,'Status word:',2X,Z4)      
      return
      end


C------------------------------------------------
      SUBROUTINE MINERR(ic,icsave,chi,min,co)
C------------------------------------------------

      IMPLICIT NONE
C
      INTEGER NPLA, NCHA, LENSEV
      PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
C
      INTEGER ic, icsave(1000), chi(1000)
      integer l, st, min,co
      INTEGER iev,iev2
      INTEGER contr
      integer stwerr(4),dumpo
C
      REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6) 
      real calselftrig(4,7), calIItrig(4), calstripshit(4),
     &     calDSPtaberr(4), calevnum(4)      
      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 calpuls(4,11,96)
      real perror(4)
C
      COMMON / evento / IEV, stwerr,perror,
     &     dexy,dexyc,base,
     &     calselftrig,calIItrig,
     &     calstripshit,calDSPtaberr,calevnum
      
      save / evento /

      COMMON / calib / IEV2, calped, calgood, calthr, calrms, 
     &     calbase,
     &     calvar,
     &     calpuls

      save / calib /
c
      COMMON / VARIE / dumpo, CONTR
      SAVE / VARIE /
                   
      st = chi(1)
      min = 1
      if (co.gt.1) then
         do l = 2, co 
            if (chi(l).lt.st) then             
               st = chi(l)
               min = l
            endif
         enddo
      endif
      ic = icsave(min)

      return
      end

C-----------------------------------------------------
      SUBROUTINE CANCTUTTO
C-----------------------------------------------------

      IMPLICIT NONE
C
      INTEGER NPLA, NCHA, LENSEV
      PARAMETER (NPLA=22,NCHA=96,LENSEV=NPLA*NCHA)
C
      INTEGER iev,iev2
      INTEGER contr
      integer stwerr(4),dumpo
C
      REAL DEXY(2,NPLA,NCHA), dexyc(2,npla,ncha), base(2,npla,6) 
      real calselftrig(4,7), calIItrig(4), calstripshit(4),
     &     calDSPtaberr(4), calevnum(4)
      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 calpuls(4,11,96)
      real perror(4)
C
      COMMON / evento / IEV, stwerr,perror,
     &     dexy,dexyc,base,
     &     calselftrig,calIItrig,
     &     calstripshit,calDSPtaberr,calevnum
      
      save / evento /

      COMMON / calib / IEV2, calped, calgood, calthr, calrms, 
     &     calbase,
     &     calvar,
     &     calpuls

      save / calib /
c
      COMMON / VARIE / dumpo, CONTR
      SAVE / VARIE /
C
      call azero(calped,4*11*96)
      call azero(calgood,4*11*96)
      call azero(calthr,4*11*96)
      call azero(calrms,4*11*96)
      call azero(calbase,4*11*6)
      call azero(calvar,4*11*6)
      call azero(calpuls,4*11*96)
      call azero(dexy,4*11*96)
      call azero(dexyc,4*11*96)
      call azero(base,4*11*6)
      call azero(calselftrig,4*7)
      call azero(calIItrig,4)
      call azero(calstripshit,4)
      call azero(calDSPtaberr,4)
      call azero(calevnum,4)
c
      return 
      end