mode_searchgrp.f90

Go to the documentation of this file.

!-----------------------------------------------------------------
!--------------- special set of characters for RCS information
!-----------------------------------------------------------------
! $Source: /mesonh/MAKE/lib/COMPRESS/src/searchgrp.f90,v $ $Revision: 1.1 $ $Date: 2003/02/14 16:06:01 $
!-----------------------------------------------------------------
!-----------------------------------------------------------------
MODULE mode_searchgrp
IMPLICIT NONE 
TYPE sop_t
  INTEGER :: nbgrp
  INTEGER,DIMENSION(:),POINTER :: ibeg
  INTEGER,DIMENSION(:),POINTER :: iend
  INTEGER,DIMENSION(:),POINTER :: valmin
  INTEGER,DIMENSION(:),POINTER :: valmax
END TYPE sop_t

INTEGER,EXTERNAL :: fminbits_in_word

! Private variables
INTEGER,SAVE,                           PRIVATE :: igrp
INTEGER,DIMENSION(:),ALLOCATABLE,TARGET,PRIVATE :: ibeg,iend,valmax,valmin
INTEGER,PARAMETER,                      PRIVATE :: mainseuil=8
INTEGER,SAVE,                           PRIVATE :: igrpmax
INTEGER,SAVE,                           PRIVATE :: icount
INTEGER,DIMENSION(16),PARAMETER,      PRIVATE :: minelt=(/4,4,4,4,5,5,6,6,7,8,9,11,13,17,26,51/)

! Private routines
PRIVATE :: recsearch_grp

CONTAINS 
SUBROUTINE ini_sopdata(SOPDATA)
TYPE(sop_t), INTENT(OUT) :: SOPDATA

sopdata%NBGRP = 0
NULLIFY(sopdata%IBEG)
NULLIFY(sopdata%IEND)
NULLIFY(sopdata%VALMIN)
NULLIFY(sopdata%VALMAX)

END SUBROUTINE ini_sopdata

SUBROUTINE recsearch(KTAB,SOPDATA)
INTEGER,DIMENSION(:) :: KTAB
TYPE(sop_t), INTENT(OUT) :: SOPDATA

INTEGER :: NELT
INTEGER :: GELT,BGELT

IF (ALLOCATED(ibeg)) THEN
  DEALLOCATE(ibeg,iend,valmax,valmin)
END IF

nelt=SIZE(ktab)
ALLOCATE(ibeg(nelt),iend(nelt),valmax(nelt),valmin(nelt))
icount = 0
igrp   = 0
igrpmax = nelt
 CALL recsearch_grp(1,nelt,ktab,mainseuil)
gelt = maxval(iend(1:igrp)-ibeg(1:igrp)+1)
bgelt = fminbits_in_word(gelt)

#ifdef DEBUG
print *,'Routine RECSEARCH_GRP appelee',icount,'fois.'
print *,'Nbre de groupes =',igrp
print *,'Nbre maxi d''elements dans groupes',gelt
print *,'Nbre de bits pour coder le nombre d''elements:',bgelt
#endif

sopdata%NBGRP=igrp
sopdata%IBEG=>ibeg
sopdata%IEND=>iend
sopdata%VALMIN=>valmin
sopdata%VALMAX=>valmax

END SUBROUTINE recsearch

RECURSIVE SUBROUTINE recsearch_grp(IND1,IND2,ITAB,ISEUIL)
INTEGER,             INTENT(IN) :: IND1,IND2,ISEUIL
INTEGER,DIMENSION(:),INTENT(IN) :: ITAB

INTEGER :: II
INTEGER :: IMAX,IMIN
INTEGER :: IVAL
INTEGER :: nbitcod
INTEGER :: tmpidx1,tmpidx2

icount=icount+1

IF (igrp == 0) THEN
  imin = minval(itab(ind1:ind2))
  imax = maxval(itab(ind1:ind2))
  igrp = 1
  valmin(igrp) = imin
  valmax(igrp) = imax
  ibeg(igrp) = ind1
  iend(igrp) = ind2
ELSE
  imin = valmin(igrp)
  imax = valmax(igrp)
END IF

IF (imax > imin) THEN

  ibeg(igrp) = ind1
  iend(igrp) = ind1
  valmin(igrp) = itab(ind1)
  valmax(igrp) = itab(ind1)
  
  DO ii=ind1,ind2-1
    ival = itab(ii+1)
    imax=max(valmax(igrp),ival)
    imin=min(valmin(igrp),ival)
    IF ((imax-imin)<(2**iseuil)) THEN
      ! II+1 belong to group IGRP
      iend(igrp) = ii+1
      valmin(igrp) = imin
      valmax(igrp) = imax
    ELSE
      ! Search the created group
      nbitcod=fminbits_in_word(valmax(igrp)-valmin(igrp))
#ifdef DEBUG
      print *,'F:(IGRP,IBEG,IEND,MAX,MIN,nbitcod)=',igrp,',',ibeg(igrp),',',iend(igrp),',',valmax(igrp),',',valmin(igrp),',',nbitcod
#endif      
      IF (iend(igrp)-ibeg(igrp)>minelt(nbitcod+1)) THEN
        IF (nbitcod > 0) THEN
          tmpidx1=ibeg(igrp)
          tmpidx2=iend(igrp)
#ifdef DEBUG
          print *,'Appel 1 RECSEARCH_GRP (first,last,seuil):',tmpidx1,tmpidx2,nbitcod/2
#endif
          CALL recsearch_grp(tmpidx1,tmpidx2,itab,nbitcod/2)
        END IF
      ELSE
        IF (igrp > 1) THEN
          nbitcod=fminbits_in_word(valmax(igrp-1)-valmin(igrp-1))
          imin=min(valmin(igrp-1),valmin(igrp))
          imax=max(valmax(igrp-1),valmax(igrp))
          IF (iend(igrp-1)-ibeg(igrp-1)<=minelt(nbitcod+1)) THEN
            IF ((imax-imin) < 2**15) THEN 
            ! concat IGRP-1 and IGRP
              iend(igrp-1) = iend(igrp)
              valmin(igrp-1) = imin
              valmax(igrp-1) = imax
              igrp = igrp-1
            END IF
          ELSE
            IF (fminbits_in_word(imax-imin) <= nbitcod) THEN
              ! concat IGRP-1 and IGRP
              iend(igrp-1) = iend(igrp)
              valmin(igrp-1) = imin
              valmax(igrp-1) = imax
              igrp = igrp-1
            END IF
          END IF
        END IF
      END IF
      ! New group is created
      igrp = igrp+1
      IF (igrp>igrpmax) THEN
        print *,'ERROR max number of group exceeded !'
        stop
      END IF
      ibeg(igrp) = ii+1
      iend(igrp) = ii+1
      valmin(igrp) = ival
      valmax(igrp) = ival
    END IF
  END DO
#ifdef DEBUG
  print *,'L:',igrp,':',valmax(igrp)-valmin(igrp),fminbits_in_word(valmax(igrp)-valmin(igrp))
#endif
  nbitcod = fminbits_in_word(valmax(igrp)-valmin(igrp))
  IF (iend(igrp)-ibeg(igrp)>= minelt(nbitcod+1)) THEN
    IF (nbitcod > 0) THEN
      tmpidx1=ibeg(igrp)
      tmpidx2=iend(igrp)
#ifdef DEBUG
      print *,'Appel 2 RECSEARCH_GRP (first,last,seuil):',tmpidx1,tmpidx2,nbitcod/2
#endif
      CALL recsearch_grp(tmpidx1,tmpidx2,itab,nbitcod/2)
    END IF
  END IF
END IF
    
END SUBROUTINE recsearch_grp

SUBROUTINE invertcol(ITAB,KX,KY)
IMPLICIT NONE 
INTEGER,                  INTENT(IN)   :: KX,KY
INTEGER,DIMENSION(KX,KY), INTENT(INOUT)::ITAB

itab(:,2:ky:2) = itab(kx:1:-1,2:ky:2)

END SUBROUTINE invertcol

END MODULE mode_searchgrp