Télécharger r2ite.eso

Retour à la liste

Numérotation des lignes :

  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
  112. C CALL PTINIT(COORD,IDIMC,NBN,ZEROTR,RTVL(ICOORD),IERR)
  113. C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER ---
  114. CALL COPIVE(COORD,(NBN*IDIMC),RTVL(ICOORD))
  115. C
  116. C ===================================================
  117. C --- CALCUL DES SPHERES ET DES COEFICIENTS DES ELEMENTS ------
  118. C ===================================================
  119. DO 20 I=1,NBE
  120. CALL SPCREE(IDIMC,I,ITRNOE((I-1)*NBNMAX+1),RTVL(ICOORD),
  121. > RTVL(ISPH),ZEROTR,iarr)
  122. C CALL FADEC(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX, voir plus loin
  123. CALL D2IDEF(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  124. > RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX,
  125. > ITAB,RTAB,COEF,TS,iarr)
  126. RTVL((I-1)*NBSMAX+ISPH+2) = COEF
  127. C
  128. IF( iarr .NE. 0 )THEN
  129. CALL DSERRE(1,iarr,'R2ITE',
  130. > 'CALCUL DE LA TAILLE SOUHAITE')
  131. GOTO 999
  132. ENDIF
  133. 20 CONTINUE
  134. C -------- POUR LE DEBUG ---------------
  135. NCFMAX = IDE
  136. IF( ITRACE.NE.0 )THEN
  137. C PRINT *,'VERIF TRIANGULATION INITIALE'
  138. C CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  139. C > NBE,NCFMAX,ITRACE,IERR)
  140. C CALL DEBORIEN(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  141. C > NOETRI,NBE,RTVL(ICOORD),ITRACE,IERR)
  142. C CALL DEBDELF1(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  143. C > NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH),
  144. C > ITRACE,ZEROTR,IERR)
  145. IF( iarr .NE. 0 )THEN
  146. C CALL DEBTABIPR(ITRNOE,NBE,3,1)
  147. C CALL DEBTABRPR(RTVL(ISPH),NBE,3,1)
  148. GO TO 999
  149. ENDIF
  150. ENDIF
  151. C
  152. NBSMAX = 3
  153. IPT = NBN
  154. 30 iarr = 0
  155. C --- POUR LE DEBUG ---
  156. C CALL DEBSTRF1(2,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  157. C > NBE,NBN,ITRACE,IERR)
  158. C IF( IERR .NE. 0 )THEN
  159. C CALL DSERRE(1,IERR,'NOEUDS INTERIEURS',' RAF2D')
  160. C GO TO 999
  161. C ENDIF
  162. C ==============================
  163. C ---- CHOIX DE L'ELEMENT A RAFFINER ----------------------
  164. C ==============================
  165. C
  166. CALL R2RCH(IDIMC,ITRNOE,NBNMAX,
  167. > NBE,RTVL(ICOORD),RTVL(ISPH),
  168. > NBSMAX,IT,XPT,COEF,iarr)
  169. C
  170. C IF( ITRACE.NE.0 )
  171. C > PRINT *,' IT =',IT,' 2*L/RC =',COEF,' XPT = ',XPT(1),XPT(2)
  172. C ==================================
  173. C --- FIN : PLUS D'ELEMENTS A RAFFINER ---
  174. C ==================================
  175. C IF((IT.EQ.0).OR.(COEF.LT.0.9999D0))THEN
  176. IF((IT.EQ.0).OR.(COEF.GT.0.6666D0))THEN
  177. C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER ---
  178. CALL COPIVE(RTVL,(NBN*IDIMC),COORD)
  179. C PRINT *,'NOMBRE DE NOEUD GENERES = ',NBN - NCOORD
  180. C PRINT *,'NOMBRE DE NOEUD TESTES = ',IPT - NCOORD
  181. GOTO 999
  182. ENDIF
  183. C ===================================================
  184. C --- TAILLE MINI. DES NOUVEAUX ELEMENTS ------
  185. C ===================================================
  186. CALL D2IDEF(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  187. > RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX,
  188. > ITAB,RTAB,COEF2,TS,iarr)
  189. C --- POUR LE DEBUG ---
  190. IF((1.D0-COEF2).LT.0.0001D0)THEN
  191. C PRINT *,'ERREUR ET FIN ',COEF, COEF2
  192. CALL R2RCH(IDIMC,ITRNOE,NBNMAX,
  193. > NBE,RTVL(ICOORD),RTVL(ISPH),
  194. > NBSMAX,IT,XPT,COEF,iarr)
  195. GOTO 999
  196. ENDIF
  197. C -------------------------------------------------------------
  198. C POUR EVITER LA GENERATION D'ELEMENTS APPLATIS A LA FRONTIERE
  199. C ON INTERDIT LES SURFACES TROP PETITES
  200. C SZERO = SURFACE D'UN TRIANGLE EQUILATERAL DE RAYON 0.75 * TS
  201. C TS = RAYON SOUHAITE POUR LE CERCLE CIRCONSCRIT
  202. C -------------------------------------------------------------
  203. SZERO = COEF3 * TS**2 * 0.421875D0
  204. C =====================================
  205. C ---- INSERTION DANS LE MAILLAGE 2D ---------------------
  206. C =====================================
  207. IF((NBE+2 .GT. NBEMAX ).OR.(NBN+1.GT.NBPMAX))THEN
  208. iarr = -2
  209. GOTO 999
  210. ENDIF
  211. IPT = IPT + 1
  212. CALL S0AJNO(XPT,RTVL(ICOORD),IDIMC,NBN,NBPMAX,
  213. > NOETRI,NOEMAX,IPTNEW,iarr)
  214. C IF( ITRACE .NE. 0 )THEN
  215. C PRINT *,'*********************'
  216. C PRINT *,'AJOUT DU POINT :',IPTNEW
  217. C ENDIF
  218. C
  219. CALL TAJPOT(IPTNEW,IT,ITRNOE,NBNMAX,ITRTRI,
  220. > NBCMAX,NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH),
  221. > NBSMAX,ITVL,IMAX,SZERO,NBTNEW,iarr)
  222. C
  223. IF( iarr.NE.0 )THEN
  224. IF(iarr.EQ.-2)GOTO 999
  225. RTVL((IT-1)*NBSMAX+2+ISPH) = 1.D0
  226. CALL S0DTNO(IPTNEW,RTVL(ICOORD),IDIMC,NBN,NBPMAX,
  227. > NOETRI,NOEMAX,iarr)
  228. IF(iarr.EQ.-2)GOTO 999
  229. iarr = 0
  230. ELSE
  231. C ===================================================
  232. C --- MISE A JOUR DES COEFICIENTS DES NOUVEAUX ELEMENTS ------
  233. C ===================================================
  234. NBENEW = NBENEW + NBTNEW
  235. DO 40 I=1,NBTNEW
  236. CALL D2IDEF(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  237. > RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX,
  238. > ITAB,RTAB,COEF,TS,iarr)
  239. RTVL((I-1)*NBSMAX+ISPH+2) = COEF
  240. 40 CONTINUE
  241. ENDIF
  242. C -------- POUR LE DEBUG ---------------
  243. NCFMAX = IDE
  244. C IF(( ITRACE .NE. 0 ).AND.( IERR .EQ. 0 ))THEN
  245. IF( ITRACE .NE. 0 )THEN
  246. C PRINT *,'VERIF TRIANGULATION INITIALE'
  247. C
  248. C CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  249. C > NBE,NCFMAX,ITRACE,IERR)
  250. C CALL DEBORIEN(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  251. C > NOETRI,NBE,RTVL(ICOORD),ITRACE,IERR)
  252. C CALL DEBDELF1(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  253. C > NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH),
  254. C > ITRACE,ZEROTR,IERR)
  255. IF( iarr .NE. 0 )THEN
  256. C PRINT *,'ERREUR DANS LA VERIFICATION'
  257. C CALL DEBTABIPR(ITRNOE,NBE,3,1)
  258. C CALL DEBTABRPR(RTVL(ISPH),NBE,3,1)
  259. GO TO 999
  260. ENDIF
  261. ENDIF
  262. C -------- FIN POUR DEBUG ---------------
  263. IF( IPTNEW .LT. NBPMAX )GO TO 30
  264. C PRINT *,' NOMBRE MAXIMUM DE NOEUDS GENERES',IPTNEW
  265. C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER ---
  266. iarr = -2
  267. CALL COPIVE(RTVL,(NBN*IDIMC),COORD)
  268. C
  269. 999 END
  270.  
  271.  
  272.  
  273.  

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