util_pares.f

Go to the documentation of this file.

      MODULE util_pares

      IMPLICIT NONE

      CONTAINS

      FUNCTION i2char2 (INT_IN)
      !-----------------------------------------------------------------------
      ! DESCRIPTION:
      !
      ! CONVERTS AN INTEGER INTO A STRING. MAXIMUM OF 12 DIGITS.
      ! THE INTEGER IS FORMATTED PROPERLY SO THAT THE RETURNED STRING CAN
      ! THEN BE TRIMMED ( TRIM(I2CHAR() )
      !-----------------------------------------------------------------------
      IMPLICIT NONE
      !-----------------------------------------------------------------------
      ! ARGUMENTS
      INTEGER, INTENT(IN) :: INT_IN ! THE INTEGER TO CONVERT
      CHARACTER (LEN=12) :: I2CHAR2
      !-----------------------------------------------------------------------
      ! LOCAL VARIABLES
      CHARACTER(LEN=12) :: STRING    ! TEMPORARY STRING
      CHARACTER(LEN=5)  :: THEFORMAT ! FORMAT TO USE FOR THE INTEGER
      INTEGER           :: N         ! NUMBER OF DECIMALS IN THE INTEGER
      !-----------------------------------------------------------------------
      ! WE LOOK FOR N SUCH THAT 10^{N-1} < INT_IN < 10^{N}
      ! THIS IS DONE TO MAKE SURE THAT WE DO NOT CREATE A FORMAT "OVERFLOW"
      n = 1
      DO WHILE (int_in.GE.10**n)
        n = n + 1
      ENDDO

      ! CHECK ON THE "LENGTH" OF THE INTEGER
      IF (n .LE. 9) THEN

        ! WRITE THE INTEGER IN A STRING WITH THE RIGHT FORMAT
        WRITE(unit=theformat,fmt='(''(I'',I1,'')'')') n
        WRITE(unit=string,fmt=theformat) int_in

      ELSE IF ( (n .GE. 10) .AND. (n .LE. 12) ) THEN

        ! WRITE THE INTEGER IN A STRING WITH THE RIGHT FORMAT
        WRITE(unit=theformat,fmt='(''I'',I2)') n
        WRITE(unit=string,fmt=theformat) int_in

      ELSE
        ! IT IS NOT POSSIBLE TO OUTPUT THIS INTEGER WITHT HE DEFAULT FORMAT
        WRITE(*,*)'FORMAT ERROR IN I2CHAR2.'
      ENDIF

      ! TRIM THE STRING AND RETURN
      i2char2 = trim(string)
      !-----------------------------------------------------------------------
      END FUNCTION i2char2

!     ---------------------------------------------------

      SUBROUTINE calc_neleb(IKLE, NELEM, NPOIN,NELEB)

      !-----------------------------------------------------------------------

      IMPLICIT NONE

      !-----------------------------------------------------------------------
      ! GLOBAL VARIABLES
      !VOIR LA SUBROUTINE VOISIN31.F DONT CETTE PROCEDURE EST DIRECTEMENT INSPIRE
      !
      INTEGER,          INTENT(IN)  :: NELEM
      INTEGER,          INTENT(IN)  :: NPOIN
      INTEGER,          INTENT(IN)  :: IKLE(nelem,4)
      INTEGER,          INTENT(OUT) :: NELEB
      !-----------------------------------------------------------------------
      ! VARIABLES LOCALES

      INTEGER :: NVOIS(npoin),IADR(npoin)
      INTEGER :: I,INOEUD,IELEM,IPOIN,ADR,IMAX,NBTRI,NV,NMXVOISIN,
     &           ivois,iface,m1,m2,m3,i1,i2,i3,nface,itri,ielem2,iface2
      INTEGER, DIMENSION(:), ALLOCATABLE :: NEIGH
      INTEGER, DIMENSION(:,:), ALLOCATABLE :: IKLE_TRI,VOIS_TRI,IFABOR
      LOGICAL :: FOUND
      !   ~~~~~~~~~~~~~~~~~~~~~~~
      !     DEFINITION DES QUATRE TRIANGLES DU TETRAEDRE : LA PREMIERE
      !     DIMENSION DU TABLEAU EST LE NUMERO DU TRIANGLE, LA DEUXIEME DONNE
      !     LES NUMEROS DES NOEUDS DE TETRAEDRES QUI LE DEFINISSENT.
      INTEGER :: SOMFAC(3,4)
      parameter( somfac = reshape((/ 1,2,3 , 4,1,2 ,
     &                                2,3,4 , 3,4,1 /),(/3,4/) ))

!-----------------------------------------------------------------------
      nface=4
!-----------------------------------------------------------------------
! ETAPE 1 : Comptage du nombre d'elements voisins d'un noeud.
!-----------------------------------------------------------------------
      DO i = 1, npoin
        nvois(i) = 0
      END DO
      DO inoeud = 1, 4
        DO ielem = 1,nelem
          ipoin        = ikle( ielem , inoeud )
          nvois(ipoin) = nvois(ipoin) + 1
        END DO
      END DO

!-----------------------------------------------------------------------
! ETAPE 2 : Determination de la taille du tableau NEIGH() et de la
! table auxiliaire pour indexer NEIGH. allocation de NEIGH
!-----------------------------------------------------------------------
      adr       = 1
      iadr(1)   = adr
      nv        = nvois(1)
      nmxvoisin = nv

      DO ipoin = 2,npoin
          adr         = adr + nv
          iadr(ipoin) = adr
          nv          = nvois(ipoin)
          nmxvoisin   = max(nmxvoisin,nv)
      END DO

      imax = iadr(npoin) + nvois(npoin)

      ALLOCATE(neigh(imax))
!-----------------------------------------------------------------------
! ETAPE 3 : initialisation de NEIGH
!-----------------------------------------------------------------------
      nvois(:) = 0

      DO inoeud = 1, 4
        DO ielem=1,nelem
          ipoin     = ikle( ielem , inoeud )
          nv           = nvois(ipoin) + 1
          nvois(ipoin) = nv
          neigh(iadr(ipoin)+nv) = ielem
        END DO
      END DO
!-----------------------------------------------------------------------
! ETAPE 4 : Reperer les faces communes des tetraedres et remplir le
! tableau IFABOR.
!-----------------------------------------------------------------------
      nbtri = nmxvoisin * 3
!
      ALLOCATE(ikle_tri(nbtri,3))
      ALLOCATE(vois_tri(nbtri,2))
      ALLOCATE(ifabor(nelem,4))
      ifabor(:,:) = 0
      DO ipoin = 1, npoin
        ikle_tri(:,:) = 0
        vois_tri(:,:) = 0
        nbtri         = 0
        nv            = nvois(ipoin)
        adr           = iadr(ipoin)
        DO ivois = 1, nv
          ielem = neigh(adr+ivois)
          DO iface = 1 , nface
            IF ( ifabor(ielem,iface) .EQ. 0 ) THEN
              i1 = ikle(ielem,somfac(1,iface))
              i2 = ikle(ielem,somfac(2,iface))
              i3 = ikle(ielem,somfac(3,iface))
              m1 = max(i1,(max(i2,i3)))
              m3 = min(i1,(min(i2,i3)))
              m2 = i1+i2+i3-m1-m3
              found = .false.
              DO itri = 1, nbtri
                IF ( ikle_tri(itri,1) .EQ. m1 ) THEN
                  IF ( ikle_tri(itri,2) .EQ. m2 .AND.
     &                 ikle_tri(itri,3) .EQ. m3 ) THEN
                    ielem2 = vois_tri(itri,1)
                    iface2 = vois_tri(itri,2)
                    ifabor(ielem ,iface ) = ielem2
                    ifabor(ielem2,iface2) = ielem
                    found = .true.
                  END IF
                END IF
              END DO
              IF ( .NOT. found) THEN
                nbtri             = nbtri + 1
                ikle_tri(nbtri,1) = m1
                ikle_tri(nbtri,2) = m2
                ikle_tri(nbtri,3) = m3
                vois_tri(nbtri,1) = ielem
                vois_tri(nbtri,2) = iface
              END IF
            END IF
          END DO
!
        END DO
      END DO
      !
      neleb = count(ifabor==0)
      DEALLOCATE(neigh)
      DEALLOCATE(ikle_tri)
      DEALLOCATE(vois_tri)
      DEALLOCATE(ifabor)
      !-----------------------------------------------------------------------
      RETURN
      END SUBROUTINE calc_neleb

      END MODULE util_pares