Sources Esope | Cast3M

rf2far
C RF2FAR    SOURCE    CHAT      06/03/29    21:31:22     5360
      SUBROUTINE RF2FAR(NN,INTER, NINTER,
     >                  ITRNOE,NBNMAX,ITRTRI,NBCMAX,
     >                  NOETRI,NBE,COORD,
     >                  ITVL,NTIMAX,RTVL,NTRMAX,iarr)
C     *****************************************************************
C     OBJET : FORCE LE MAILLAGE A RESPECTER UNE ARETE
C
C     EN ENTREE:
C      NN()    :  LES INDICES DES NOEUDS DE L'ARETE
C      INTER   :  TABLEAU DES ELEMENTS INTERSECTANTS NN()
C      NINTER  :  NBRE D'ELEMENTS DE INTER
C                 AU MINIMUM = 8 * NINTER + 10
C                 AU MAXIMUM = (NBR MAX D'ELEMENTS EN 1 NOEUD + 1) *
C                 (NUMERO MAXI DES NOEUDS DES ELEMENTS DE INTER)
C
C      ITVL    :  TABLEAU DE TRAVAIL (ENTIERS)
C      NTIMAX  :  TAILLE DU TABLEAU ITVL
C      RTVL    :  TABLEAU DE TRAVAIL (REELS)
C      NTRMAX  :  TAILLE DU TABLEAU RTVL
C
C     EN SORTIE: LE MAILLAGE MODIFIE SI NECESSAIRE.
C      iarr    : 0 SI OK
C          -1 SI LES DONNEES SONT ERRONEES
C             NN(1) OU NN(2) N'APPARTIENNT PAS AUX ELEMENTS DE INTER
C          -2 SI ITVL EST TROP PETIT
C     REMARQUE : ATTENTION LES MAILLES DE INTER SONT RENUMEROTEE DE
C                1 A CARD(INTER), ITRNOE,ITRTRI...SONT MODIFIES !!!
C     *****************************************************************
      IMPLICIT INTEGER(I-N)
      INTEGER   NN(*),INTER(*),NINTER,ITRNOE(*),NBNMAX
      INTEGER   ITRTRI(*),NBCMAX,NOETRI(*),NBE
      INTEGER   ITVL(*),NTIMAX,NTRMAX,iarr
      REAL*8      COORD(*), RTVL(*)
C    on enleve l'external TC
C      REAL*8      TRRILF
C      EXTERNAL  TRRILF
      INTEGER   IDE,I,NBN,NBC,NBIFR,NBIFR1,IND,IFR
      INTEGER   NIFMAX
      INTEGER   IT,IF,IT1,J, NOEUD, IFR2, NBCOL, NOEMAX
      INTEGER   IPOLY,NBPP,IPOLY1,NBPP1,IPOLY2,NBPP2
      INTEGER   INOE,ITRI,ITRAV,NBTRAV
      INTEGER   NBFNOE, N, ISOMP, NBSOMP, NCC
      INTEGER   ITRIP1, ITRIP2, ITI, ITR, NTIMX, NTRMX
      REAL*8      QTMIN1, QTMIN2
C
      IDE = 2
      iarr = 0
      IF(NTIMAX.LT.(8*NINTER+10))THEN
         iarr = -2
         GO TO 999
      ENDIF
C         ====================================================
C     --- 1. COMPRESSION DU MAILLAGE ET CALCUL DE LA FRONTIERE
C         ====================================================
C
C     ITVL = |  IFR  |
C                 2*NBIFR
C
      CALL ENSTRI(INTER,NINTER)
      NOEMAX = 1
      CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
     >             NOEMAX,NBE,INTER,NINTER,iarr)
      IF( iarr .NE. 0  )THEN
        CALL DSERRE(1,iarr,'RF2FAR',' APPEL NUCOMP')
        GOTO 999
      ENDIF
C
      IND = 1
      IFR = 1
      NBIFR = 0
      NIFMAX = NTIMAX
      CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NINTER,
     >                   ITVL(IFR),NBIFR,NIFMAX,iarr)
C
C      PRINT *,' FRONTIERE '
C      PRINT *,' ',((ITVL((I-1)*2+IFR-1+J),J=1,2),I=1,NBIFR)
      IF( iarr .NE. 0  )THEN
        CALL DSERRE(1,iarr,'RF2FAR',' APPEL TMAFRT')
        GOTO 999
      ENDIF
C          =========================================
C     --- 2. CREATION DES 2 POLYGONES A TRIANGULER. -----
C          =========================================
C     ITVL = |  IFR |   INOE  |  ITRI   | IPOLY
C                2*NBIFR NBN*NBIFR NBC*NBIFR
C
      NBN = 2
      NBC = 2
      NBIFR = NINTER + 2
C
C     --- 2.1 CREATION DU MAILLAGE LINEIQUE ---
C         ----------------------------------
C     LE NOMBRE DE PARAMETRES DE SFRCRE A CHANGE ??? O.STAB 07.95
C     >              ITRTRI,NBCMAX,NOETRI,NBE,ITVL(ITRAV),NBTRAV,
C
      INOE   = ( 2 * NBIFR ) + 1
      ITRI   = ( NBN * NBIFR ) + INOE
      ITRAV  = ( NBC * NBIFR ) + ITRI
C     --- ECONOMIE DE FNOETRI --
      NBTRAV = (NBC + 1) * NBIFR
      NBFNOE = 0
C      WRITE(6,*)'APPEL SFRCRE'
      CALL SFRCRE(IDE,ITVL(IFR),NBIFR,ITRNOE,NBNMAX,
     >              ITVL(ITRAV),NBTRAV,
     >              ITVL(INOE),NBN,ITVL(ITRI),NBC,NBIFR,
     >              ITVL(1),NBFNOE,NCC,iarr)
C      PRINT *,' MAILLAGE FRONTIERE '
C      PRINT *,' ',((ITVL((I-1)*2+INOE-1+J),J=1,2),I=1,NBIFR)
      IF( iarr .NE. 0  )THEN
        CALL DSERRE(1,iarr,'RF2FAR',' APPEL SFRCRE')
        GOTO 999
      ENDIF
C
C     ---- 2.2 FRONTIERE EXTERIEURE ---------
C         --------------------------
      NBIFR1 = 0
      DO 30 I=1,NBIFR
        IT = ITVL((I-1)*2+IFR)
        IF = ITVL((I-1)*2+IFR+1)
        IT1 = ITRTRI((IT-1)*NBCMAX+IF)
        IF( IT1.NE.0 )THEN
          DO 10 J=1,NBCMAX
            IF( ITRTRI((IT1-1)*NBCMAX+J).EQ.IT )GO TO 20
   10     CONTINUE
          iarr = -1
          GO TO 999
   20     NBIFR1 = NBIFR1 + 1
          ITVL((NBIFR1-1)*2+IFR) = IT1
          ITVL((NBIFR1-1)*2+IFR+1) = J
        ENDIF
   30 CONTINUE
C      PRINT *,' FRONTIERE EXTERIEUR '
C      PRINT *,' ',((ITVL((I-1)*2+IFR+J-1),J=1,2),I=1,NBIFR1)
C
C     ---- DESTRUCTION DES MAILLES SANS MISE A JOUR DE NOETRI ----
C      MODIF O.STAB 18.08.95 DEPLACE APRES LE CALCUL
C      => PERMET UN RETOUR EN ARRIERE EN CAS D'ERREUR
C
C      N = 3
C      NBSOMP = 0
C      ISOMP = 1
C      DO 40 I=1,NINTER
C        CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI,
C     >                   NBFNOE,I,N,ITVL(ISOMP),NBSOMP,iarr)
C        IF( iarr .NE. 0  )THEN
C     40 CONTINUE
C
C     --- 2.3 CONSTRUCTION DU POLYGONE ---
C         -----------------------------
C     BUG1 : IPOLY = ITRI + ( NBC * NBIFR ) + 1
C     REMPLACE PAR :
      IPOLY = (6* NBIFR) + MAX(1,NBIFR-4)
C      PRINT *,' APPEL ARTOPL '
      CALL ARTOPL(ITVL(INOE),2,ITVL(ITRI),2,
     >             ITVL(IPOLY),NBPP)
C      PRINT *,' POLYGONE  RESULTANT '
C      PRINT *,' ',(ITVL(IPOLY+I),I=0,(NBPP-1))
C      PRINT *,' ORIGINE, EXTREMITE = ',NN(1),NN(2)
      IF( NBPP .LE. 3  )THEN
        iarr = -1
        CALL DSERRE(1,iarr,'RF2FAR',
     >      ' POLYGONE A MOINS DE 4 COTES')
        GOTO 999
      ENDIF
C
C
C       --- 2.4 DECOUPAGE DU POLYGONE ---
C          ---------------------------
C     ITVL = | IFR |   XXXXX     | IPOLY1 | IPOLY2 | IPOLY
C                2*NBIFR NINTER * 3   NBIFR   NBIFR   NBIFR
C
C       ON STOQUE D'ABORD LA FRONTIERE PUIS LA TRIANGULATION
C       PUIS ENFIN LES POLYGONES
C
        IPOLY1 = (2 * NBIFR) + (NINTER * 3 ) + 1
C       IPOLY1 CONTIENT AU MAX NBPP COTES (NBPP = NBIFR)
C        IPOLY2 = IPOLY1 + NBPP - 1
        IPOLY2 = IPOLY1 + NBIFR - 1
C       DANS LE PIRE CAS C'EST IPOLY2 QUI CONTIENT NBPP COTES
C        PRINT *,' APPEL SPLIPL '
C        PRINT *,'IPOLY1,IPOLY2,IPOLY = ',IPOLY1,IPOLY2,IPOLY
        CALL SPLIPL(ITVL(IPOLY),NBPP,NN,ITVL(IPOLY1),NBPP1,
     >                 ITVL(IPOLY2),NBPP2,iarr)
        IF(iarr.NE.0)THEN
C        PRINT *,' POLYGONE  RESULTANT '
C        PRINT *,' ',(ITVL(IPOLY+I),I=0,(NBPP-1))
C        PRINT *,' POLYGONE  1 '
C        PRINT *,' ',(ITVL(IPOLY1+I),I=0,(NBPP1-1))
C        PRINT *,' POLYGONE  2 '
C        PRINT *,' ',(ITVL(IPOLY2+I),I=0,(NBPP2-1))
          CALL DSERRE(1,iarr,'RF2FAR',' APPEL SPLIPL')
          GOTO 999
        ENDIF
C
C             ===========================
C     -------- 3. TRIANGULATION DU TROU  ------------------
C             ===========================
C     ITVL = |NBIFR|  ITRIP1  |  ITRIP2   | IPOLY1 | IPOLY2 |
C                              NINTER * 3          NBIFR   NBIFR
C
        ITRIP1 = ( 2 * NBIFR ) + 1
        ITRIP2 = ( 3 *(NBPP1-2) ) + ITRIP1
        ITR    = 1
        NTRMX  = NTRMAX
        ITI    = IPOLY2 + NBIFR
        NTIMX  = NTIMAX - ITI
C
C        PRINT *,' PREMIER APPEL TRPLS2 '
        CALL TRPLS2(COORD,ITVL(IPOLY1),NBPP1,
     >              ITVL(ITI),NTIMX,RTVL(ITR),NTRMX,
C     >              ITVL(ITRIP1),TRRILF,QTMIN1,iarr) modif TC esxternal
     >              ITVL(ITRIP1),QTMIN1,iarr)
        IF(iarr.NE.0)THEN
          CALL DSERRE(1,iarr,'RF2FAR',' PREMIER APPEL TRPLS2')
          GOTO 999
        ENDIF
C
C        PRINT *,' DEUXIEME APPEL TRPLS2 '
        CALL TRPLS2(COORD,ITVL(IPOLY2),NBPP2,
     >              ITVL(ITI),NTIMX,RTVL(ITR),NTRMX,
C     >              ITVL(ITRIP2),TRRILF,QTMIN2,iarr) modif TC external
     >              ITVL(ITRIP2),QTMIN2,iarr)
        IF(iarr.NE.0)THEN
          CALL DSERRE(1,iarr,'RF2FAR',' DEUXIEME APPEL TRPLS2')
          GOTO 999
        ENDIF
C        PRINT *,'QUALITE T1   QUALITE T2 '
C        PRINT  '(F7.6,F7.6)',QTMIN1,QTMIN2
C
C         =======================================================
C     ---- 4. DESTRUCTION DES MAILLES SANS MISE A JOUR DE NOETRI ----
C         =======================================================
      N = 3
      NBSOMP = 0
      ISOMP = 1
C      PRINT *,' APPEL SMADET '
      DO 50 I=1,NINTER
        CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI,
     >                   NBFNOE,I,N,ITVL(ISOMP),NBSOMP,iarr)
        IF( iarr .NE. 0  )THEN
           CALL DSERRE(1,iarr,'RF2FAR',' APPEL SMADET')
           GOTO 999
        ENDIF
   50 CONTINUE
C         =================================
C     --- 5. CREATION DU NOUVEAU MAILLAGE ---
C         =================================
      NBFNOE = 0
C     --- ON LIBERE LES IPOLYS ---
      ITRAV  = IPOLY1
C      PRINT *,' APPEL SMACRE '
      NBTRAV = NTIMAX - ITRAV + 1
      CALL SMACRE(IDE,ITVL(ITRIP1),NINTER,0,
     >             ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBFNOE,
     >             ITVL(ITRAV),NBTRAV,iarr)
      IF( iarr .NE. 0  )THEN
        CALL DSERRE(1,iarr,'RF2FAR',' APPEL SMACRE')
        GOTO 999
      ENDIF
C     --- POUR LE DEBUG -------
C      PRINT *,'TABLEAU DES NOEUDS '
C      PRINT *,((ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX),I=1,NINTER)
C      PRINT *,'TABLEAU DES VOISINS '
C      PRINT *,((ITRTRI((I-1)*NBCMAX+J),J=1,NBCMAX),I=1,NINTER)
C
C     --- COLLAGE DES FRONTIERES ---
C
      IND = 1
C     --- ON LIBERE LA TRIANGULATION ---
      IFR2 = ITRIP1
      NIFMAX = NTIMAX - ITRIP1
C      PRINT *,' APPEL TMAFRT '
      CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NINTER,
     >                   ITVL(IFR2),NBIFR,NIFMAX,iarr)
      IF( iarr .NE. 0  )THEN
           CALL DSERRE(1,iarr,'RF2FAR',' APPEL TMAFRT')
           GOTO 999
         ENDIF
C
C     --- MISE A JOUR DE ITRTRI -----------------
C
C      PRINT *,' APPEL S2GLAR '
      CALL S2GLAR(ITVL(IFR),NBIFR1,ITVL(IFR2),NBIFR,
     >                 ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBCOL)
C
C     --- MISE A JOUR DE NOETRI -----------------
C
      DO 90 I=1,NINTER
        DO 80 J=1,NBNMAX
          NOEUD = ITRNOE((I-1)*NBNMAX+J)
          IF( NOEUD .NE. 0 )NOETRI(NOEUD)=I
   80   CONTINUE
   90 CONTINUE
  999 END