1 : C R2CPO SOURCE CHAT 06/03/29 21:31:02 5360 2 : SUBROUTINE R2CPO(ITAB,RTAB, 3 : C SUBROUTINE R2CPO(FADEC,ITAB,RTAB, 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 : IDEM R2ITE A 2 LIGNES PRES (POUR LES CHAMPS DE POINTS) 9 : C EN ENTREE 10 : C --------- LE DECOUPAGE ------------------- 11 : C fadec directement remplacer par D2CHPO TC 12 : C FADEC : FONCTION D'EVALUATION DU DECOUPAGE ET DE 13 : C CALCUL D'UN NOEUD, ELLE A LE FORMAT SUIVANT : 14 : C 15 : C FADEC(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 16 : C COORD,IDIMC,SPH,NBSMAX,ITAB,RTAB,COEF,TS,iarr) 17 : C CF. DEN2DFPSUOBJIT 18 : C 19 : C ITAB : PARAMETRES ENTIERS DE LA FONCTION FADEC 20 : C RTAB : PARAMETRES REELS DE LA FONCTION FADEC 21 : C 22 : C ITVL : TABLEAU DE TRAVAIL (6*NBADET+10) 23 : C IMAX : TAILLE DU TABLEAU DE TRAVAIL 24 : C RTVL : TABLEAU DE TRAVAIL COORDONNEES + SPHERES 25 : C IRMAX : TAILLE DE RTVL >= 3*(3*NBNPTMAX-2*NBN+NBE) 26 : C --------- LE MAILLAGE --------------------- 27 : C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE : LE MAILLAGE 28 : C COORD,IDIMC: LES COORDONNEES DES NOEUDS 29 : C NBPMAX : NOMBRE MAXIMUM DE POINTS (TAILLE DES TABLEAUX COORD,NOETRI) 30 : C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS (TAILLE DES TABLEAUX ITRNOE,ITRTRI) 31 : C 32 : C EN SORTIE : LE MAILLAGE MODIFIE 33 : C NBN : LE NOMBRE DE NOEUDS = NBP + NBPNEW 34 : C NBE : LE NOMBRE D'ELEMENTS = 2 * NBPNEW + NBE 35 : C NBENEW : LE NOMBRE D'ELEMENTS GENEREES = 2 * NBPNEW 36 : C iarr : CODE D'ERREUR 37 : C -1 TOUS LES POINTS N'ONT PAS PU ETRE AJOUTES 38 : C -2 DEPASSEMENT DE LA CAPACITE DES TABLEAUX 39 : C REMARQUES : 40 : C NBPNEW : LE NOMBRE DE NOEUDS GENERES = NBENEW / 2 41 : C ********************************************************************** 42 : IMPLICIT INTEGER(I-N) 43 : INTEGER ITAB(*) 44 : REAL*8 RTAB(*) 45 : INTEGER NBE,NBEMAX,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX 46 : INTEGER ITVL(*),IMAX 47 : INTEGER IDIMC,NOETRI(*),NOEMAX,NBN,NBPMAX,IRMAX,NBENEW,iarr 48 : REAL*8 COORD(*),RTVL(*) 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 : CALL D2CHPO(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.9999))THEN 162 : IF((IT.EQ.0).OR.(COEF.GT.0.6666))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 D2CHPO(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.0001)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 : C SZERO = COEF3 * TS**2 * 0.421875 - DESACTIVE 187 : SZERO = 0.0D0 188 : SZERO = COEF3* TS**2 * 0.10546875D0 189 : C ===================================== 190 : C ---- INSERTION DANS LE MAILLAGE 2D --------------------- 191 : C ===================================== 192 : IF((NBE+2 .GT. NBEMAX ).OR.(NBN+1.GT.NBPMAX))THEN 193 : iarr = -2 194 : GOTO 999 195 : ENDIF 196 : IPT = IPT + 1 196 : CALL S0AJNO(XPT,RTVL(ICOORD),IDIMC,NBN,NBPMAX, 197 : > NOETRI,NOEMAX,IPTNEW,iarr) 198 : C IF( ITRACE .NE. 0 )THEN 199 : C PRINT *,'*********************' 200 : C PRINT *,'AJOUT DU POINT :',IPTNEW 201 : C ENDIF 202 : C 202 : CALL TAJPOT(IPTNEW,IT,ITRNOE,NBNMAX,ITRTRI, 203 : > NBCMAX,NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH), 204 : > NBSMAX,ITVL,IMAX,SZERO,NBTNEW,iarr) 205 : C 206 : IF( iarr.NE.0 )THEN 207 : IF( iarr.EQ.-2 )GOTO 999 208 : RTVL((IT-1)*NBSMAX+2+ISPH) = 1.D0 208 : CALL S0DTNO(IPTNEW,RTVL(ICOORD),IDIMC,NBN,NBPMAX, 209 : > NOETRI,NOEMAX,iarr) 210 : IF( iarr.EQ.-2 )GOTO 999 211 : iarr = 0 212 : ELSE 213 : C =================================================== 214 : C --- MISE A JOUR DES COEFICIENTS DES NOUVEAUX ELEMENTS ------ 215 : C =================================================== 216 : C AJOUT D'UNE LIGNE POUR LA MISE A JOUR DES CHAMPS POINTS 217 : RTAB(IPTNEW) = TS 218 : NBENEW = NBENEW + NBTNEW 219 : DO 40 I=1,NBTNEW 219 : CALL D2CHPO(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 220 : > RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX, 221 : > ITAB,RTAB,COEF,TS,iarr) 222 : RTVL((I-1)*NBSMAX+ISPH+2) = COEF 223 : 40 CONTINUE 224 : ENDIF 225 : C -------- POUR LE DEBUG --------------- 226 : NCFMAX = IDE 227 : C IF(( ITRACE .NE. 0 ).AND.( IERR .EQ. 0 ))THEN 228 : IF( ITRACE .NE. 0 )THEN 229 : C PRINT *,'VERIF TRIANGULATION INITIALE' 230 : C 230 : C CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, 231 : C > NBE,NCFMAX,ITRACE,IERR) 231 : C CALL DEBORIEN(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 232 : C > NOETRI,NBE,RTVL(ICOORD),ITRACE,IERR) 232 : C CALL DEBDELF1(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 233 : C > NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH), 234 : C > ITRACE,ZEROTR,IERR) 235 : IF( iarr .NE. 0 )THEN 236 : C PRINT *,'ERREUR DANS LA VERIFICATION' 236 : C CALL DEBTABIPR(ITRNOE,NBE,3,1) 236 : C CALL DEBTABRPR(RTVL(ISPH),NBE,3,1) 237 : GO TO 999 238 : ENDIF 239 : ENDIF 240 : C -------- FIN POUR DEBUG --------------- 241 : IF( IPTNEW .LT. NBPMAX )GO TO 30 242 : C PRINT *,' NOMBRE MAXIMUM DE NOEUDS GENERES',IPTNEW 243 : C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER --- 244 : iarr = -2 244 : CALL COPIVE(RTVL,(NBN*IDIMC),COORD) 245 : C 246 : 999 END 247 : 248 : 249 : 250 :
© Cast3M 2003 - All rights reserved.
Disclaimer