Télécharger tnupot.eso

Retour à la liste

tnupot
C TNUPOT    SOURCE    PV        22/04/19    21:15:05     11344          
      SUBROUTINE TNUPOT(COORD,NBN,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
     >                   NOETRI,NBE,ITVL,IMAX,RTVL,iarr)
C     **********************************************************************
C     OBJET : TRIANGULATION D'UN NUAGE DE POINTS
C
C     EN ENTREE  :
C       COORD    : COORDONNEES DES POINTS
C       NBN      : NOMBRE DE POINTS
C       ITVL : TABLEAU DE TRAVAIL. ON EMPILE SUCCESSIVEMENT :
C                  LA TRIANGULATION INITIALE QUI NECESSITE : 3 * 50
C                  PUIS SIMULTANEMENT LE NOMBRE DE NOEUDS REJETES, ET
C                  LE TABLEAU DE TRAVAIL POUR TAJPOT = (6*NBADET +10)
C                  D'OU IMAX > MAX(150,(6*NBADET+10)+NREJET)
C
C       IMAX     : TAILLE DU TABLEAU DE TRAVAIL
C       RTVL : TABLEAU DE TRAVAIL DE (8*NBN+244)
C
C     EN SORTIE  : LA TRIANGULATION MISE A JOUR
C
C       ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI : LA TRIANGULATION
C       NBNMAX   : =3 A MOINS D'ETRE DONNE (NBNMAX != 0 EN ENTREE)
C       NBCMAX   : =3 A MOINS D'ETRE DONNE (NBCMAX != 0 EN ENTREE)
C
C       iarr     : CODE D'ERREUR
C                  -1 TRIANGULATION INCOMPLETE : TOUS LES POINTS N'ONT PAS
C                     PU ETRE AJOUTES
C                  -2 ITVL TROP PETIT
C     **********************************************************************
      IMPLICIT INTEGER(I-N)
      REAL*8       COORD(*)
      INTEGER    NBN
      INTEGER    ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX
      INTEGER    NOETRI(*),NBE,ITVL(*),IMAX,iarr
      REAL*8       RTVL(*)
C
C     --- POUR LE DEBUG ---
C
C      COMMON /DEBUG/ ITRACE, ITEST, IERROR, IMESS
C      INTEGER       ITRACE, ITEST, IERROR
C      CHARACTER*256 IMESS
C
C     --- POUR LES STATS ---
C
C      COMMON /STATS/ ICARD(100), TEMPSCPU(100)
C      INTEGER       ICARD
C      REAL        TEMPSCPU
C     --- CONSTANTES ---
      INTEGER   NADMAX
      PARAMETER ( NADMAX = 50 )
      REAL*8      ZEROTR, SZERO
      PARAMETER ( ZEROTR = 1.D-30, SZERO = 1.D-8 )
C     --- VARIABLES INTERNES ---
      REAL*8    BOITE(6)
      INTEGER IDIMC,IDE,NBC,NCOORD, NBFNOE, NOEMAX, ISENS
      INTEGER ITRI,NBPB,ITRAV,NBTRAV,I,J,IPT,ITC,IF2,NP(2),NCC
      INTEGER ISOMP,NBSOMP,ISPH,NTMEM
      INTEGER NCFMAX,NREJET,NBP,ICOORD,NPASSE
      INTEGER ITD,NBSMAX,NBTNEW
      INTEGER NOP, ITRACE
C
      ITRACE = 0
      IDIMC = 2
      IF( NBN .EQ. 0 )THEN
        iarr = -1
        GO TO 999
      ENDIF
      IF( NBNMAX.EQ.0 )NBNMAX = 3
      IF( NBCMAX.EQ.0 )NBCMAX = 3
      IF(( NBNMAX.LT.3 ).OR.(NBCMAX.LT.3))THEN
        iarr = -1
        GOTO 999
      ENDIF
      IF( IDIMC .EQ. 2 )THEN
C        NBE = (2*(NBN+4)) + 2 - 4
C        NTMEM =(NBE*3)+((NBE+2)*2)+(NBE*3)+((NBN*7)+NBE)
C        NBE = 2*NBN + 6
C        NTMEM = 27 * NBN
        NTMEM = MAX(150,(6*NADMAX+10))
        IF( NTMEM.GT.IMAX )THEN
          iarr = -2
          GO TO 999
        ENDIF
      ENDIF
C
C     ---- 1. INITIALISATION -----------------------------------------
C     NORMALISATION DES POINTS (PTINIT)
C     CALCUL DU MAILLAGE INITIAL ENGLOBANT (T2INIT)
C     CALCUL DES SPHERES CIRCONSCRITES
C     ----------------------------------------------------------------
      NBE = 0
      IDE = IDIMC
      NBC = IDIMC + 1
      NCOORD = NBN
C     ISPH = 1
      ISPH = IDIMC * ( NBN + 50 ) + 1
      ICOORD = 1
      ITRI = 1
      DO 5 I=1,IDIMC
        BOITE(I) = -1.0D0
        BOITE(IDIMC+I) = 1.0D0
    5 CONTINUE
      CALL PTINIT(COORD,IDIMC,NBN,ZEROTR,RTVL(ICOORD),iarr)
C      CALL PTBOITENC(COORD,IDIMC,NBN,BOITE)
C      ITRI = 1
C
C     --- TRIANGULATION DE LA BOITE D'ENCOMBREMENT --------------------
C
C      CALL TRI2DBOITE(BOITE,ITVL(ITRI),NBE,
C     >              COORD((NBN*IDIMC)+1),NBPB)
C
      CALL T2INIT(BOITE,(1-NBN),ITVL(ITRI),NBE,
     >              RTVL((NBN*IDIMC)+ICOORD),NBPB)
C
      IPT = 2
      DO 10 I=0,(NBE*(IDIMC+1))-1
        ITVL(ITRI+I) = ITVL(ITRI+I) + NBN
   10 CONTINUE
      NCOORD  = NCOORD + NBPB
      NOEMAX = NCOORD
      ITRAV    = ITRI + (NBE * NBC)
      NBTRAV   = IMAX - ITRAV
      CALL SMAOCR(IDE,ITVL(ITRI),NBE,RTVL(ICOORD),NCOORD,
     >           IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,
     >           ITVL(ITRAV),NBTRAV,NCC,iarr)
      DO 20 I=1,NBE
        CALL SPCREE(IDIMC,I,ITRNOE((I-1)*NBNMAX+1),RTVL(ICOORD),
     >             RTVL(ISPH),ZEROTR,iarr)
        IF( iarr .NE. 0  )THEN
          CALL DSERRE(1,iarr,'TNUPOT','CALCUL DES SPHERES')
          GOTO 999
        ENDIF
   20 CONTINUE
C     -------- POUR LE DEBUG ---------------
      NCFMAX = IDE
      IF( ITRACE.NE.0 )THEN
C        PRINT *,'VERIF TRIANGULATION INITIALE'
C      CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
C       >                   NBE,NCFMAX,ITRACE,iarr)
C        CALL DEBORIEN(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
C       >                   NOETRI,NBE,RTVL(ICOORD),ITRACE,iarr)
C        CALL DEBDELF1(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
C       >                   NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH),
C       >                   ITRACE,ZEROTR,iarr)
      IF( iarr .NE. 0 )THEN
C        CALL DEBTABIPR(ITRNOE,NBE,3,1)
C        CALL DEBTABRPR(RTVL(ISPH),NBE,3,1)
        GO TO 999
      ENDIF
      ENDIF
C
C     ---- 2. AJOUT DES NOEUDS ----------------------------------------
C
      NPASSE = 0
      DO 25 I=IPT,NBN
        ITVL(I)=I
   25 CONTINUE
C
      ITD = 0
      NBP = NBN
      NBSMAX = 3
C      IPT = 1
      NREJET = 0
   30 iarr = 0
      IF( ITRACE .NE. 0 )THEN
C        PRINT *,'*********************'
C        PRINT *,'AJOUT DU POINT :',IPT
      ENDIF
      CALL TAJPOT(ITVL(IPT),ITD,ITRNOE,NBNMAX,ITRTRI,
     >           NBCMAX,NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH),
     >           NBSMAX,ITVL(NBP+1), (IMAX-NBP),SZERO,
     >           NBTNEW,iarr)
      IF( iarr.NE.0 )THEN
C         IF( ITRACE .EQ. 1 )PRINT *,'ERREUR A L AJOUT DU POINT :',IPT
C        ----- PERMUTATION : EN FIN -------
         NREJET = NREJET + 1
         ITVL(NREJET) = ITVL(IPT)
      ENDIF
C     -------- POUR LE DEBUG ---------------
      NCFMAX = IDE
      IF((ITRACE .NE. 0 ).AND.( iarr .NE. 0 ))GOTO 999
C     -------- FIN POUR DEBUG ---------------
      IPT = IPT+1
      IF( IPT .LE. NBP )GO TO 30
C     -------- ON PASSE AU REJETES ---------
C     -------- TOUS LES POINTS REJETES -----
      IF( NREJET .GE. NBP )THEN
      IF( NPASSE .LT. 10 )THEN
        NPASSE = NPASSE + 1
        NBP = NREJET
        IPT = 1
        NREJET = 0
        iarr = 0
        GOTO 30
      ELSE
        iarr = -1
        CALL DSERRE(1,iarr,'TNUPOT','BOUCLE REJET')
C       ---- ON CONTINUE QUAND MEME POUR VERIFICATION ----
        iarr = 0
        GO TO 35
C       ENDIF
      ENDIF
      ENDIF
C
      IF( NREJET .NE. 0 )THEN
        NPASSE = 0
        NBP = NREJET
        IPT = 1
        NREJET = 0
        GO TO 30
      ENDIF
C
C     ---- 3. DESTRUCTION DES ELEMENTS BIDON --------------------------
C
   35 CONTINUE
      ITRACE = 0
      ISENS = 1
      NBFNOE = 1
      DO 50 I=1,NBPB
        NP(1) = NBN + I
   40    CALL SESFR2(NP,ISENS,IDE,ITRNOE,NBNMAX,ITRTRI,
     >                NBCMAX,NOETRI,ITC,IF2)
C       --- DE LA PREMIERE ARETE DE FRONTIERE ---
        IF( ITC.EQ. 0 )GO TO 50
        IF( ITRTRI((ITC-1)*NBCMAX+IF2)  .NE. 0 )THEN
          iarr = -1
          CALL DSERRE(1,iarr,'TNUPOT','DESTRUCTION FINALE')
          GO TO 999
        ENDIF
C     --- L'ELEMENT EST MIS A LA FIN : PERMUTE ITC ET NBE ---------
      IF( ITRACE .NE. 0 )THEN
C        PRINT *,'DESTRUCTION DE ',ITC
C        PRINT *,(ITRNOE((ITC-1)*NBNMAX+J),J=1,NBNMAX)
      ENDIF
      CALL NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
     >              NBFNOE,NBE,ITC,NBE,iarr)
C     --- LE DERNIER ELEMENT EST DETRUIT --------------------------
      ISOMP = 1
      NBSOMP = 0
      CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI,
     >           NBFNOE,NBE,NBC,ITVL(ISOMP),NBSOMP,iarr)
      NBE = NBE-1
      IF( iarr .NE. 0  )THEN
          iarr = -1
          CALL DSERRE(1,iarr,'TNUPOT','DESTRUCTION FINALE')
         GO TO 999
       ENDIF
      IF( NBSOMP .EQ. 0 )GO TO 40
C     --- LE NOEUD (NBN + I) EST DECONNECTE ----------------------
   50 CONTINUE
C        ==================================
C     --- MISE A JOUR DE NOETRI : O(3*NBE) ---
C        ==================================
      DO 70 I=1,NBE
        DO 60 J=1,3
           NOP = ITRNOE((I-1)*NBNMAX+J)
           IF((NOP.GT.NBN).OR.(NOP.LE.0))THEN
             iarr = -1
             GOTO 999
           ENDIF
           NOETRI(NOP) = I
   60   CONTINUE
   70 CONTINUE
C
      IF( NREJET.NE. 0 )iarr = -1
  999 END
 
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales