Télécharger r2cpo.eso

Retour à la liste

Numérotation des lignes :

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

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