ranbo.f

Go to the documentation of this file.

!                       ****************
                        SUBROUTINE ranbo
!                       ****************
!
     &(nbor,kp1bor,ifabor,ikle,ncolor,trav1,nptfr,x,y,ncolfr,
     & ndp,npoin,nelem,nelmax,mesh)
!
!***********************************************************************
!  PROGICIEL : STBTEL V5.2   10/02/93    J.M. JANIN   (LNH)
!***********************************************************************
!
!brief  Building the table of boundary segments
!

!history  S.E.BOURBAN (HRW)
!+        21/03/2017
!+        V7P3
!+   Replacement of the DATA declarations by the PARAMETER associates
!
!-----------------------------------------------------------------------
!                             ARGUMENTS
! .________________.____.______________________________________________.
! |      NOM       |MODE|                   ROLE                       |
! |________________|____|______________________________________________|
! |    NBOR        |<-- | TABLEAU DES POINTS DE BORD                   |
! |    IFABOR      | -->| TABLEAU DES VOISINS DES FACES.               |
! |    IKLE        | -->| NUMEROS GLOBAUX DES POINTS DE CHAQUE ELEMENT |
! |    NCOLOR      | -->| TABLEAU DES COULEURS DES POINTS              |
! |    NCOLFR      |<-- | TABLEAU DES COULEURS DES POINTS DE BORD      |
! |    TRAV1       |<-->| TABLEAU DE TRAVAIL                           |
! |    NPTFR       |<-- | NOMBRE DE POINTS DE BORD
! |________________|____|______________________________________________
! | COMMON:        |    |
! |  GEO:          |    |
! |    MESH        | -->| TYPE DES ELEMENTS DU MAILLAGE
! |    NDP         | -->| NOMBRE DE NOEUDS PAR ELEMENTS
! |    NPOIN       | -->| NOMBRE TOTAL DE NOEUDS DU MAILLAGE
! |    NELEM       | -->| NOMBRE TOTAL D'ELEMENTS DU MAILLAGE
! |    NELMAX      | -->| DIMENSION EFFECTIVE DES TABLEAUX CONCERNANT
! |                |    | LES ELEMENTS (NELMAX = NELEM + 0.2*NELEM)
! |________________|____|______________________________________________|
!  MODE: -->(DONNEE NON MODIFIEE),<--(RESULTAT),<-->(DONNEE MODIFIEE)
!-----------------------------------------------------------------------
! APPELE PAR : STBTEL
! APPEL DE : -
!***********************************************************************
!
      USE declarations_special
      IMPLICIT NONE
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER, INTENT(IN)    :: NDP,NELMAX,MESH,NELEM,NPOIN
      INTEGER, INTENT(INOUT) :: NPTFR
      INTEGER, INTENT(INOUT) :: NBOR(*),KP1BOR(*),NCOLFR(*)
      INTEGER, INTENT(INOUT) :: TRAV1(npoin,2)
      INTEGER, INTENT(IN)    :: IFABOR(nelmax,*),IKLE(nelmax,ndp)
      INTEGER, INTENT(IN)    :: NCOLOR(*)
      DOUBLE PRECISION, INTENT(IN) :: X(npoin),Y(npoin)
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER IILE,NILE,I,ISUIV,IELEM,IFACE,NOEUD1,NOEUD2
      INTEGER IERROR, I1, I2
!
      DOUBLE PRECISION SOM1,SOM2,Y2
!
      LOGICAL SWAP
!
      INTEGER :: SOMSUI(4) = (/ 2 , 3 , 4 , 0 /)
      DOUBLE PRECISION, PARAMETER :: EPSILO = 1.d-6
!
!=======================================================================
! INITIALISATION
!=======================================================================
!
      somsui(ndp) = 1
      IF (mesh.NE.2.AND.mesh.NE.3) THEN
        WRITE(lu,4000) mesh
4000    FORMAT(/,1x,'RANBO : MESH NOT ALLOWED , MESH = ',i4,/)
        CALL plante(1)
        stop
      ENDIF
!
!=======================================================================
! RECHERCHE DES ARETES DE BORD,NUMEROTEES DE 1 A NPTFR
!=======================================================================
!
      nptfr = 0
      DO ielem=1,nelem
        DO iface=1,ndp
          IF(ifabor(ielem,iface).LE.0) THEN
            nptfr = nptfr + 1
            trav1(nptfr,1) = ikle(ielem,       iface )
            trav1(nptfr,2) = ikle(ielem,somsui(iface))
          ENDIF
        ENDDO
      ENDDO
!
!=======================================================================
! ON VERIFIE QUE CHAQUE POINT N'APPARAIT QUE DEUX FOIS
! ( UNE FOIS COMME NOEUD 1 , UNE FOIS COMME NOEUD 2 )
!=======================================================================
!
      ierror = 0
      DO i=1,nptfr
        i1 = 1
        i2 = 1
        DO isuiv=1,nptfr
          IF (trav1(i,1).EQ.trav1(isuiv,2)) i1 = i1 + 1
          IF (trav1(i,2).EQ.trav1(isuiv,1)) i2 = i2 + 1
        ENDDO
        IF (i1.NE.2) THEN
          ierror = ierror + 1
          WRITE(lu,1020) x(trav1(i,1)),y(trav1(i,1)),i1
        ENDIF
        IF (i2.NE.2) THEN
          ierror = ierror + 1
          WRITE(lu,1020) x(trav1(i,2)),y(trav1(i,2)),i2
        ENDIF
      ENDDO
!
1020  FORMAT(1x,'ERROR ON BOUNDARY NODE :',/,
     &       1x,'X=',f13.3,'  Y=',f13.3,/,
     &       1x,'IT BELONGS TO',i2,' BOUNDARY SEGMENT(S)')
!
      IF (ierror.GT.0) THEN
        CALL plante(1)
        stop
      ENDIF
!
!=======================================================================
! RANGEMENT DES ARETES DE BORD BOUT A BOUT.
! ON COMMENCE ARBITRAIREMENT PAR LE POINT LE PLUS SUD-OUEST
! ( PUIS LE PLUS SUD SI CONFLIT ) AFIN D'ETRE SUR DE COMMENCER
! SUR LE CONTOUR ET NON SUR UNE ILE |||
!=======================================================================
!
      som2 = x(1) + y(1)
      y2   = y(1)
!
      DO i=1,nptfr
!
        som1 = x(trav1(i,1)) + y(trav1(i,1))
        IF (abs(som1-som2).LE.abs(epsilo*som1)) THEN
          IF (y(trav1(i,1)).LE.y2) THEN
            y2    = y(trav1(i,1))
            som2  = som1
            isuiv = i
          ENDIF
        ELSEIF (som1.LE.som2) THEN
          y2    = y(trav1(i,1))
          som2  = som1
          isuiv = i
        ENDIF
!
      ENDDO
!
      noeud1 = trav1(isuiv,1)
      noeud2 = trav1(isuiv,2)
      trav1(isuiv,1) = trav1(1,1)
      trav1(isuiv,2) = trav1(1,2)
      trav1(1,1) = noeud1
      trav1(1,2) = noeud2
!
      iile = 0
      nile = 1
!
      DO i=2,nptfr
        swap = .false.
!
!=======================================================================
! RECHERCHE DE L'ARETE DONT LE PREMIER NOEUD EST IDENTIQUE AU SECOND
! DE L'ARETE PRECEDENTE
!=======================================================================
!
        DO isuiv=i,nptfr
!
          IF (trav1(isuiv,1).EQ.trav1(i-1,2)) THEN
!
!=======================================================================
! PERMUTATION DES ARETES DE NUMEROS I+1 ET ISUIV
!=======================================================================
!
            noeud1 = trav1(isuiv,1)
            noeud2 = trav1(isuiv,2)
            trav1(isuiv,1) = trav1(i,1)
            trav1(isuiv,2) = trav1(i,2)
            trav1(i,1) = noeud1
            trav1(i,2) = noeud2
            kp1bor(i+nptfr) = i-1
            kp1bor(i-1) = i
            swap = .true.
            EXIT
!
          ENDIF
!
        ENDDO
        IF(swap) cycle
!
!=======================================================================
! SI ON NE TROUVE PAS DE POINT SUIVANT : ON VERIFIE QUE LE DERNIER POINT
! TROUVE EST IDENTIQUE AU PREMIER , DANS CE CAS ON EST EN PRESENCE D'UNE
! ILE ET ON ITERE LE PROCESSUS GLOBAL
!=======================================================================
!
        IF (trav1(nile,1).NE.trav1(i-1,2)) THEN
!
!=======================================================================
! SINON IL Y A ERREUR
!=======================================================================
!
          WRITE(lu,4500) trav1(i-1,2)
4500      FORMAT(1x,'ERROR IN STORING THE EDGE SEGMENTS',/,
     &           1x,'FOR THE NODE ',i5)
          CALL plante(1)
          stop
        ENDIF
!
        kp1bor(nile+nptfr) = i-1
        kp1bor(i-1) = nile
        iile = iile+1
        nile = i
!
      ENDdo! ISUIV
!
!=======================================================================
! ON VERIFIE QUE LA DERNIERE ILE EST FERMEE
!=======================================================================
!
      IF (trav1(nile,1).NE.trav1(nptfr,2)) THEN
        WRITE(lu,5000) trav1(nile,1),trav1(nptfr,2)
5000    FORMAT(1x,'ERROR, THE BOUNDARY IS NOT CLOSED :',/,
     &         1x,'FIRST POINT :',i5,2x,'LAST POINT : ',i5)
        CALL plante(1)
        stop
      ENDIF
!
      kp1bor(nile+nptfr) = nptfr
      kp1bor(nptfr) = nile
!
      WRITE(lu,5500) nptfr
      WRITE(lu,5600) iile
 5500 FORMAT(1x,'NUMBER OF BOUNDARY POINTS      : ',i5)
 5600 FORMAT(1x,'NUMBER OF ISLANDS              : ',i5)
!
!=======================================================================
! REMPLISSAGE DU TABLEAU NBOR ET STOCKAGE DE LA COULEUR DES POINTS DE
! BORD DANS LE TABLEAU NCOLFR
!=======================================================================
!
      DO i=1,nptfr
        nbor(i      ) = trav1(i,1)
        nbor(i+nptfr) = trav1(i,2)
        ncolfr(i) = ncolor(trav1(i,1))
      ENDDO
!
      RETURN
      END