Télécharger r2cpo.eso

Retour à la liste

r2cpo
C R2CPO     SOURCE    CB215821  17/11/30    21:17:05     9639           
      SUBROUTINE R2CPO(ITAB,RTAB,
C      SUBROUTINE R2CPO(FADEC,ITAB,RTAB,
     >          ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,
     >          COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX,
     >          ITVL,IMAX,RTVL,IRMAX,NBENEW,IARR)
C     *****************************************************************
C     OBJET :  IDEM R2ITE A 2 LIGNES PRES (POUR LES CHAMPS DE POINTS)
C     EN ENTREE
C       --------- LE DECOUPAGE -------------------
C fadec directement remplacer par D2CHPO TC
C       FADEC     : FONCTION D'EVALUATION DU DECOUPAGE ET DE
C                   CALCUL D'UN NOEUD, ELLE A LE FORMAT SUIVANT :
C
C           FADEC(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
C                 COORD,IDIMC,SPH,NBSMAX,ITAB,RTAB,COEF,TS,iarr)
C           CF. DEN2DFPSUOBJIT
C
C       ITAB     : PARAMETRES ENTIERS DE LA FONCTION FADEC
C       RTAB     : PARAMETRES REELS DE LA FONCTION FADEC
C
C       ITVL  : TABLEAU DE TRAVAIL (6*NBADET+10)
C       IMAX      : TAILLE DU TABLEAU DE TRAVAIL
C       RTVL  : TABLEAU DE TRAVAIL COORDONNEES + SPHERES
C       IRMAX      : TAILLE DE RTVL >= 3*(3*NBNPTMAX-2*NBN+NBE)
C       --------- LE MAILLAGE ---------------------
C       ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE : LE MAILLAGE
C       COORD,IDIMC: LES COORDONNEES DES NOEUDS
C       NBPMAX     : NOMBRE MAXIMUM DE POINTS (TAILLE DES TABLEAUX COORD,NOETRI)
C       NBEMAX     : NOMBRE MAXIMUM D'ELEMENTS (TAILLE DES TABLEAUX ITRNOE,ITRTRI)
C
C     EN SORTIE     : LE MAILLAGE MODIFIE
C       NBN       : LE NOMBRE DE NOEUDS = NBP + NBPNEW
C       NBE       : LE NOMBRE D'ELEMENTS = 2 * NBPNEW + NBE
C       NBENEW    : LE NOMBRE D'ELEMENTS GENEREES = 2 * NBPNEW
C       iarr      : CODE D'ERREUR
C                      -1 TOUS LES POINTS N'ONT PAS PU ETRE AJOUTES
C                      -2 DEPASSEMENT DE LA CAPACITE DES TABLEAUX
C     REMARQUES :
C       NBPNEW    : LE NOMBRE DE NOEUDS GENERES = NBENEW / 2
C     **********************************************************************
      IMPLICIT INTEGER(I-N)
      INTEGER ITAB(*)
      REAL*8    RTAB(*)
      INTEGER NBE,NBEMAX,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX
      INTEGER ITVL(*),IMAX
      INTEGER IDIMC,NOETRI(*),NOEMAX,NBN,NBPMAX,IRMAX,NBENEW,iarr
      REAL*8    COORD(*),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)
C      INTEGER       ICARD
C     --- CONSTANTES ---
      INTEGER   NADMAX
      PARAMETER ( NADMAX = 50 )
      REAL*8      ZEROTR
      PARAMETER ( ZEROTR = 1.D-30 )
C     --- VARIABLES INTERNES ---
      REAL*8    XPT(3)
      INTEGER IDE,NCOORD
      INTEGER I,IPT
      INTEGER ISPH,NTMEM
      INTEGER NCFMAX,ICOORD
      INTEGER IT,IPTNEW
      REAL*8    COEF, SZERO, TS, COEF2
      INTEGER NBSMAX,NBTNEW,ITRACE
      REAL*8      COEF3
C     --- COEF3 = SQRT(3) ------------
      DATA COEF3/1.73205080756887729352D0/
C
C          ==============================
C     ---- INITIALISATION                ----------------------
C          ==============================
C
      SZERO  = 1.D-8
      NBENEW = 0
      ITRACE = 0
      NBSMAX = 3
      iarr   = 0
      IPTNEW  = 0
      IF( NBN.EQ.NBPMAX )THEN
        iarr = -2
        GOTO 999
      ENDIF
      IF((NBN .EQ. 0) .OR.(IDIMC.NE. 2).OR.
     >   (NBNMAX.LT.3).OR.(NBCMAX.LT.3))THEN
        iarr = -1
        GOTO 999
      ENDIF
      NTMEM = 6*NADMAX+10
      IF( NTMEM.GT.IMAX )THEN
        iarr = -2
        GO TO 999
      ENDIF
C
C     ---- 1. INITIALISATION -----------------------------------------
C     NORMALISATION DES POINTS (PTINIT)
C     CALCUL DES SPHERES CIRCONSCRITES
C     TRI DES ELEMENTS A RAFFINER
C     ----------------------------------------------------------------
      IDE = IDIMC
      NCOORD = NBN
      ISPH = (IDIMC * NBPMAX)  + 1
      ICOORD = 1
C      CALL PTINIT(COORD,IDIMC,NBN,ZEROTR,RTVL(ICOORD),IERR)
C     --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER ---
      CALL COPIVE(COORD,(NBN*IDIMC),RTVL(ICOORD))
C
C        ===================================================
C     --- CALCUL DES SPHERES ET DES COEFICIENTS DES ELEMENTS ------
C        ===================================================
      DO 20 I=1,NBE
        CALL SPCREE(IDIMC,I,ITRNOE((I-1)*NBNMAX+1),RTVL(ICOORD),
     >             RTVL(ISPH),ZEROTR,iarr)
        CALL D2CHPO(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
     >            RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX,
     >            ITAB,RTAB,COEF,TS,iarr)
        RTVL((I-1)*NBSMAX+ISPH+2) = COEF
C
        IF( iarr .NE. 0  )THEN
          CALL DSERRE(1,iarr,'R2ITE',
     >                     'CALCUL DE LA TAILLE SOUHAITE')
          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,IERR)
C        CALL DEBORIEN(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
C       >                   NOETRI,NBE,RTVL(ICOORD),ITRACE,IERR)
C        CALL DEBDELF1(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
C       >                   NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH),
C       >                   ITRACE,ZEROTR,IERR)
      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
      NBSMAX = 3
      IPT = NBN
   30 iarr = 0
C     ---  POUR LE DEBUG ---
C      CALL DEBSTRF1(2,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
C     >              NBE,NBN,ITRACE,IERR)
C      IF( IERR .NE. 0 )THEN
C        CALL DSERRE(1,IERR,'NOEUDS INTERIEURS',' RAF2D')
C        GO TO 999
C      ENDIF
C          ==============================
C     ---- CHOIX DE L'ELEMENT A RAFFINER  ----------------------
C          ==============================
C
      CALL R2RCH(IDIMC,ITRNOE,NBNMAX,
     >           NBE,RTVL(ICOORD),RTVL(ISPH),
     >           NBSMAX,IT,XPT,COEF,iarr)
C
C      IF( ITRACE.NE.0 )
C     >  PRINT *,' IT =',IT,' 2*L/RC =',COEF,' XPT = ',XPT(1),XPT(2)
C        ==================================
C     --- FIN : PLUS D'ELEMENTS A RAFFINER ---
C        ==================================
C      IF((IT.EQ.0).OR.(COEF.LT.0.9999))THEN
      IF((IT.EQ.0).OR.(COEF.GT.0.6666))THEN
C     --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER ---
        CALL COPIVE(RTVL,(NBN*IDIMC),COORD)
C        PRINT *,'NOMBRE DE NOEUD GENERES = ',NBN - NCOORD
C        PRINT *,'NOMBRE DE NOEUD TESTES = ',IPT - NCOORD
        GOTO 999
      ENDIF
C        ===================================================
C     --- TAILLE MINI. DES NOUVEAUX ELEMENTS                ------
C        ===================================================
        CALL D2CHPO(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
     >            RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX,
     >            ITAB,RTAB,COEF2,TS,iarr)
C     --- POUR LE DEBUG ---
      IF((1.D0-COEF2).LT.0.0001)THEN
C        PRINT *,'ERREUR ET FIN ',COEF, COEF2
        CALL R2RCH(IDIMC,ITRNOE,NBNMAX,
     >           NBE,RTVL(ICOORD),RTVL(ISPH),
     >           NBSMAX,IT,XPT,COEF,iarr)
        GOTO 999
      ENDIF
C     -------------------------------------------------------------
C     POUR EVITER LA GENERATION D'ELEMENTS APPLATIS A LA FRONTIERE
C     ON INTERDIT LES SURFACES TROP PETITES
C     SZERO = SURFACE D'UN TRIANGLE EQUILATERAL DE RAYON 0.75 * TS
C     TS    = RAYON SOUHAITE POUR LE CERCLE CIRCONSCRIT
C     -------------------------------------------------------------
C      SZERO = COEF3 * TS**2 * 0.421875 - DESACTIVE
      SZERO = 0.0D0
      SZERO = COEF3* TS**2 * 0.10546875D0
C         =====================================
C     ---- INSERTION DANS LE MAILLAGE 2D       ---------------------
C         =====================================
      IF((NBE+2 .GT. NBEMAX ).OR.(NBN+1.GT.NBPMAX))THEN
        iarr = -2
        GOTO 999
      ENDIF
      IPT = IPT + 1
      CALL S0AJNO(XPT,RTVL(ICOORD),IDIMC,NBN,NBPMAX,
     >                NOETRI,NOEMAX,IPTNEW,iarr)
C      IF( ITRACE .NE. 0 )THEN
C        PRINT *,'*********************'
C        PRINT *,'AJOUT DU POINT :',IPTNEW
C      ENDIF
C
      CALL TAJPOT(IPTNEW,IT,ITRNOE,NBNMAX,ITRTRI,
     >    NBCMAX,NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH),
     >    NBSMAX,ITVL,IMAX,SZERO,NBTNEW,iarr)
C
      IF( iarr.NE.0 )THEN
         IF( iarr.EQ.-2 )GOTO 999
         RTVL((IT-1)*NBSMAX+2+ISPH) = 1.D0
         CALL S0DTNO(IPTNEW,RTVL(ICOORD),IDIMC,NBN,NBPMAX,
     >                NOETRI,NOEMAX,iarr)
         IF( iarr.EQ.-2 )GOTO 999
         iarr = 0
      ELSE
C        ===================================================
C     --- MISE A JOUR DES COEFICIENTS DES NOUVEAUX ELEMENTS ------
C        ===================================================
C     AJOUT D'UNE LIGNE POUR LA MISE A JOUR DES CHAMPS POINTS
      RTAB(IPTNEW) = TS
      NBENEW = NBENEW + NBTNEW
      DO 40 I=1,NBTNEW
        CALL D2CHPO(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
     >            RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX,
     >            ITAB,RTAB,COEF,TS,iarr)
        RTVL((I-1)*NBSMAX+ISPH+2) = COEF
   40 CONTINUE
      ENDIF
C     -------- POUR LE DEBUG ---------------
      NCFMAX = IDE
C      IF(( ITRACE .NE. 0 ).AND.( IERR .EQ. 0 ))THEN
      IF( ITRACE .NE. 0 )THEN
C        PRINT *,'VERIF TRIANGULATION INITIALE'
C
C      CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
C       >                  NBE,NCFMAX,ITRACE,IERR)
C        CALL DEBORIEN(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
C       >                  NOETRI,NBE,RTVL(ICOORD),ITRACE,IERR)
C        CALL DEBDELF1(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
C       >                  NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH),
C       >                  ITRACE,ZEROTR,IERR)
      IF( iarr .NE. 0 )THEN
C         PRINT *,'ERREUR DANS LA VERIFICATION'
C        CALL DEBTABIPR(ITRNOE,NBE,3,1)
C        CALL DEBTABRPR(RTVL(ISPH),NBE,3,1)
        GO TO 999
      ENDIF
      ENDIF
C     -------- FIN POUR DEBUG ---------------
      IF( IPTNEW .LT. NBPMAX )GO TO 30
C      PRINT *,' NOMBRE MAXIMUM DE NOEUDS GENERES',IPTNEW
C     --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER ---
      iarr = -2
      CALL COPIVE(RTVL,(NBN*IDIMC),COORD)
C
  999 END
 
 
 
 
 
 

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