1 : C R2ITE SOURCE CHAT 06/03/29 21:31:07 5360 2 : SUBROUTINE R2ITE(ITAB,RTAB, 3 : C SUBROUTINE R2ITE(FADEC,ITAB,RTAB, modif TC 4 : > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, 5 : > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, 6 : > ITVL,IMAX,RTVL,IRMAX,NBENEW,iarr) 7 : C ***************************************************************** 8 : C OBJET : RAFINE ITERATIVEMENT UN MAILLAGE TRIANGULAIRE 9 : C EN ENTREE 10 : C --------- LE DECOUPAGE ------------------- 11 : C FADEC : FONCTION D'EVALUATION DU DECOUPAGE ET DE 12 : C CALCUL D'UN NOEUD, ELLE A LE FORMAT SUIVANT : 13 : C 14 : C FADEC(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 15 : C COORD,IDIMC,SPH,NBSMAX,ITAB,RTAB,COEF,TS,IERR) 16 : C CF. DEN2DFPSUOBJIT 17 : C 18 : C ITAB : PARAMETRES ENTIERS DE LA FONCTION FADEC 19 : C RTAB : PARAMETRES REELS DE LA FONCTION FADEC 20 : C 21 : C ITVL : TABLEAU DE TRAVAIL (6*NBADET+10) 22 : C IMAX : TAILLE DU TABLEAU DE TRAVAIL 23 : C RTVL : TABLEAU DE TRAVAIL COORDONNEES + SPHERES 24 : C IRMAX : TAILLE DE RTVL >= 3*(3*NBNPTMAX-2*NBN+NBE) 25 : C --------- LE MAILLAGE --------------------- 26 : C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE : LE MAILLAGE 27 : C COORD,IDIMC: LES COORDONNEES DES NOEUDS 28 : C NBPMAX : NOMBRE MAXIMUM DE POINTS (TAILLE DES TABLEAUX COORD,NOETRI) 29 : C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS (TAILLE DES TABLEAUX ITRNOE,ITRTRI) 30 : C 31 : C EN SORTIE : LE MAILLAGE MODIFIE 32 : C NBN : LE NOMBRE DE NOEUDS = NBP + NBPNEW 33 : C NBE : LE NOMBRE D'ELEMENTS = 2 * NBPNEW + NBE 34 : C NBENEW : LE NOMBRE D'ELEMENTS GENEREES = 2 * NBPNEW 35 : C iarr : CODE D'ERREUR 36 : C -1 TOUS LES POINTS N'ONT PAS PU ETRE AJOUTES 37 : C -2 DEPASSEMENT DE LA CAPACITE DES TABLEAUX 38 : C REMARQUES : 39 : C NBPNEW : LE NOMBRE DE NOEUDS GENERES = NBENEW / 2 40 : C ********************************************************************** 41 : IMPLICIT INTEGER(I-N) 42 : INTEGER ITAB(*) 43 : REAL*8 RTAB(*) 44 : INTEGER NBE,NBEMAX,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX 45 : INTEGER ITVL(*),IMAX 46 : INTEGER IDIMC,NOETRI(*),NOEMAX,NBN,NBPMAX,IRMAX,NBENEW,iarr 47 : REAL*8 COORD(*),RTVL(*) 48 : C EXTERNAL FADEC modif TC 49 : C 50 : C --- POUR LE DEBUG --- 51 : C 52 : C COMMON /DEBUG/ ITRACE, ITEST, IERROR, IMESS 53 : C INTEGER ITRACE, ITEST, IERROR 54 : C CHARACTER*256 IMESS 55 : C 56 : C --- POUR LES STATS --- 57 : C 58 : C COMMON /STATS/ ICARD(100) 59 : C INTEGER ICARD 60 : C --- CONSTANTES --- 61 : INTEGER NADMAX 62 : PARAMETER ( NADMAX = 50 ) 63 : REAL*8 ZEROTR 64 : PARAMETER ( ZEROTR = 1.D-30 ) 65 : C --- VARIABLES INTERNES --- 66 : REAL*8 XPT(3) 67 : INTEGER IDE,NCOORD 68 : INTEGER I,IPT 69 : INTEGER ISPH,NTMEM 70 : INTEGER NCFMAX,ICOORD 71 : INTEGER IT,IPTNEW 72 : REAL*8 COEF, SZERO, TS, COEF2 73 : INTEGER NBSMAX,NBTNEW,ITRACE 74 : REAL*8 COEF3 75 : C --- COEF3 = SQRT(3) ------------ 76 : DATA COEF3/1.73205080756887729352D0/ 77 : C 78 : C ============================== 79 : C ---- INITIALISATION ---------------------- 80 : C ============================== 81 : C 82 : SZERO = 1.D-8 83 : NBENEW = 0 84 : ITRACE = 0 85 : NBSMAX = 3 86 : iarr = 0 87 : IPTNEW = 0 88 : IF( NBN.EQ.NBPMAX )THEN 89 : iarr = -2 90 : GOTO 999 91 : ENDIF 92 : IF((NBN .EQ. 0) .OR.(IDIMC.NE. 2).OR. 93 : > (NBNMAX.LT.3).OR.(NBCMAX.LT.3))THEN 94 : iarr = -1 95 : GOTO 999 96 : ENDIF 97 : NTMEM = 6*NADMAX+10 98 : IF( NTMEM.GT.IMAX )THEN 99 : iarr = -2 100 : GO TO 999 101 : ENDIF 102 : C 103 : C ---- 1. INITIALISATION ----------------------------------------- 104 : C NORMALISATION DES POINTS (PTINIT) 105 : C CALCUL DES SPHERES CIRCONSCRITES 106 : C TRI DES ELEMENTS A RAFFINER 107 : C ---------------------------------------------------------------- 108 : IDE = IDIMC 109 : NCOORD = NBN 110 : ISPH = (IDIMC * NBPMAX) + 1 111 : ICOORD = 1 111 : C CALL PTINIT(COORD,IDIMC,NBN,ZEROTR,RTVL(ICOORD),IERR) 112 : C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER --- 112 : CALL COPIVE(COORD,(NBN*IDIMC),RTVL(ICOORD)) 113 : C 114 : C =================================================== 115 : C --- CALCUL DES SPHERES ET DES COEFICIENTS DES ELEMENTS ------ 116 : C =================================================== 117 : DO 20 I=1,NBE 117 : CALL SPCREE(IDIMC,I,ITRNOE((I-1)*NBNMAX+1),RTVL(ICOORD), 118 : > RTVL(ISPH),ZEROTR,iarr) 118 : C CALL FADEC(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX, voir plus loin 118 : CALL D2IDEF(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 119 : > RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX, 120 : > ITAB,RTAB,COEF,TS,iarr) 121 : RTVL((I-1)*NBSMAX+ISPH+2) = COEF 122 : C 123 : IF( iarr .NE. 0 )THEN 123 : CALL DSERRE(1,iarr,'R2ITE', 124 : > 'CALCUL DE LA TAILLE SOUHAITE') 125 : GOTO 999 126 : ENDIF 127 : 20 CONTINUE 128 : C -------- POUR LE DEBUG --------------- 129 : NCFMAX = IDE 130 : IF( ITRACE.NE.0 )THEN 131 : C PRINT *,'VERIF TRIANGULATION INITIALE' 131 : C CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, 132 : C > NBE,NCFMAX,ITRACE,IERR) 132 : C CALL DEBORIEN(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 133 : C > NOETRI,NBE,RTVL(ICOORD),ITRACE,IERR) 133 : C CALL DEBDELF1(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 134 : C > NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH), 135 : C > ITRACE,ZEROTR,IERR) 136 : IF( iarr .NE. 0 )THEN 136 : C CALL DEBTABIPR(ITRNOE,NBE,3,1) 136 : C CALL DEBTABRPR(RTVL(ISPH),NBE,3,1) 137 : GO TO 999 138 : ENDIF 139 : ENDIF 140 : C 141 : NBSMAX = 3 142 : IPT = NBN 143 : 30 iarr = 0 144 : C --- POUR LE DEBUG --- 144 : C CALL DEBSTRF1(2,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, 145 : C > NBE,NBN,ITRACE,IERR) 146 : C IF( IERR .NE. 0 )THEN 146 : C CALL DSERRE(1,IERR,'NOEUDS INTERIEURS',' RAF2D') 147 : C GO TO 999 148 : C ENDIF 149 : C ============================== 150 : C ---- CHOIX DE L'ELEMENT A RAFFINER ---------------------- 151 : C ============================== 152 : C 152 : CALL R2RCH(IDIMC,ITRNOE,NBNMAX, 153 : > NBE,RTVL(ICOORD),RTVL(ISPH), 154 : > NBSMAX,IT,XPT,COEF,iarr) 155 : C 156 : C IF( ITRACE.NE.0 ) 157 : C > PRINT *,' IT =',IT,' 2*L/RC =',COEF,' XPT = ',XPT(1),XPT(2) 158 : C ================================== 159 : C --- FIN : PLUS D'ELEMENTS A RAFFINER --- 160 : C ================================== 161 : C IF((IT.EQ.0).OR.(COEF.LT.0.9999D0))THEN 162 : IF((IT.EQ.0).OR.(COEF.GT.0.6666D0))THEN 163 : C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER --- 163 : CALL COPIVE(RTVL,(NBN*IDIMC),COORD) 164 : C PRINT *,'NOMBRE DE NOEUD GENERES = ',NBN - NCOORD 165 : C PRINT *,'NOMBRE DE NOEUD TESTES = ',IPT - NCOORD 166 : GOTO 999 167 : ENDIF 168 : C =================================================== 169 : C --- TAILLE MINI. DES NOUVEAUX ELEMENTS ------ 170 : C =================================================== 170 : CALL D2IDEF(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 171 : > RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX, 172 : > ITAB,RTAB,COEF2,TS,iarr) 173 : C --- POUR LE DEBUG --- 174 : IF((1.D0-COEF2).LT.0.0001D0)THEN 175 : C PRINT *,'ERREUR ET FIN ',COEF, COEF2 175 : CALL R2RCH(IDIMC,ITRNOE,NBNMAX, 176 : > NBE,RTVL(ICOORD),RTVL(ISPH), 177 : > NBSMAX,IT,XPT,COEF,iarr) 178 : GOTO 999 179 : ENDIF 180 : C ------------------------------------------------------------- 181 : C POUR EVITER LA GENERATION D'ELEMENTS APPLATIS A LA FRONTIERE 182 : C ON INTERDIT LES SURFACES TROP PETITES 183 : C SZERO = SURFACE D'UN TRIANGLE EQUILATERAL DE RAYON 0.75 * TS 184 : C TS = RAYON SOUHAITE POUR LE CERCLE CIRCONSCRIT 185 : C ------------------------------------------------------------- 186 : SZERO = COEF3 * TS**2 * 0.421875D0 187 : C ===================================== 188 : C ---- INSERTION DANS LE MAILLAGE 2D --------------------- 189 : C ===================================== 190 : IF((NBE+2 .GT. NBEMAX ).OR.(NBN+1.GT.NBPMAX))THEN 191 : iarr = -2 192 : GOTO 999 193 : ENDIF 194 : IPT = IPT + 1 194 : CALL S0AJNO(XPT,RTVL(ICOORD),IDIMC,NBN,NBPMAX, 195 : > NOETRI,NOEMAX,IPTNEW,iarr) 196 : C IF( ITRACE .NE. 0 )THEN 197 : C PRINT *,'*********************' 198 : C PRINT *,'AJOUT DU POINT :',IPTNEW 199 : C ENDIF 200 : C 200 : CALL TAJPOT(IPTNEW,IT,ITRNOE,NBNMAX,ITRTRI, 201 : > NBCMAX,NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH), 202 : > NBSMAX,ITVL,IMAX,SZERO,NBTNEW,iarr) 203 : C 204 : IF( iarr.NE.0 )THEN 205 : IF(iarr.EQ.-2)GOTO 999 206 : RTVL((IT-1)*NBSMAX+2+ISPH) = 1.D0 206 : CALL S0DTNO(IPTNEW,RTVL(ICOORD),IDIMC,NBN,NBPMAX, 207 : > NOETRI,NOEMAX,iarr) 208 : IF(iarr.EQ.-2)GOTO 999 209 : iarr = 0 210 : ELSE 211 : C =================================================== 212 : C --- MISE A JOUR DES COEFICIENTS DES NOUVEAUX ELEMENTS ------ 213 : C =================================================== 214 : NBENEW = NBENEW + NBTNEW 215 : DO 40 I=1,NBTNEW 215 : CALL D2IDEF(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 216 : > RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX, 217 : > ITAB,RTAB,COEF,TS,iarr) 218 : RTVL((I-1)*NBSMAX+ISPH+2) = COEF 219 : 40 CONTINUE 220 : ENDIF 221 : C -------- POUR LE DEBUG --------------- 222 : NCFMAX = IDE 223 : C IF(( ITRACE .NE. 0 ).AND.( IERR .EQ. 0 ))THEN 224 : IF( ITRACE .NE. 0 )THEN 225 : C PRINT *,'VERIF TRIANGULATION INITIALE' 226 : C 226 : C CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, 227 : C > NBE,NCFMAX,ITRACE,IERR) 227 : C CALL DEBORIEN(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 228 : C > NOETRI,NBE,RTVL(ICOORD),ITRACE,IERR) 228 : C CALL DEBDELF1(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 229 : C > NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH), 230 : C > ITRACE,ZEROTR,IERR) 231 : IF( iarr .NE. 0 )THEN 232 : C PRINT *,'ERREUR DANS LA VERIFICATION' 232 : C CALL DEBTABIPR(ITRNOE,NBE,3,1) 232 : C CALL DEBTABRPR(RTVL(ISPH),NBE,3,1) 233 : GO TO 999 234 : ENDIF 235 : ENDIF 236 : C -------- FIN POUR DEBUG --------------- 237 : IF( IPTNEW .LT. NBPMAX )GO TO 30 238 : C PRINT *,' NOMBRE MAXIMUM DE NOEUDS GENERES',IPTNEW 239 : C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER --- 240 : iarr = -2 240 : CALL COPIVE(RTVL,(NBN*IDIMC),COORD) 241 : C 242 : 999 END 243 : 244 : 245 :
© Cast3M 2003 - All rights reserved.
Disclaimer