Télécharger amelio.eso

Retour à la liste

Numérotation des lignes :

  1. C AMELIO SOURCE CHAT 05/01/12 21:21:20 5004
  2. C CE SOUS PROGRAMME AMELIORE LA QUALITE DU MAILLAGE ISSU DE TRANSF
  3. C EN DEUX TEMPS INVERSION DES DIAGONALES PUIS DEPLACEMENT DES NOEUDS
  4. C
  5. SUBROUTINE AMELIO(X,NUM,NUMELG ,NUMNP,NUMINI,ICLE,IVOI,ISUP,QUAL,
  6. # KON,NCTIN,NBNN)
  7. IMPLICIT INTEGER(I-N)
  8. IMPLICIT REAL*8 (A-H,O-Z)
  9. -INC CCOPTIO
  10. DIMENSION X(3,1),NUM(NBNN,1),IVOI(1),KON(ISUP,1)
  11. C LA QUALITE N'EST AUTRE QUE LE RAPPORT DE LA SURFACE ET DU CARRE DU
  12. C PLUS GRAND COTE
  13. CAL(I,J,K)=((X(1,J)-X(1,I))*(X(2,K)-X(2,J))-(X(2,J)-X(2,I))*
  14. # (X(1,K)-X(1,J)))/(0.866*MAX((X(1,J)-X(1,I))**2+(X(2,J)-X(2,I))
  15. # **2,(X(1,K)-X(1,J))**2+(X(2,K)-X(2,J))**2,(X(1,I)-X(1,K))**2+
  16. # (X(2,I)-X(2,K))**2))
  17. ANG(I,J,K)=ATAN2((X(1,J)-X(1,K))*(X(2,J)-X(2,I))-(X(2,J)-X(2,K))*
  18. # (X(1,J)-X(1,I)),(X(1,J)-X(1,K))*(X(1,J)-X(1,I))+(X(2,J)-X(2,K))*
  19. # (X(2,J)-X(2,I)))
  20. IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NUMELG,NUMINI,NUMNP
  21. 1000 FORMAT(' AJUST A FAIT ',I5,' ELEMENTS ET LES NOEUDS DE ',I5,' A ',
  22. #I6)
  23. IF (NUMELG.LE.1) RETURN
  24. IRANGE=NUMNP-NCTIN+1
  25. DO 200 I=1,IRANGE
  26. 200 IVOI(I)=0
  27. DO 202 I=1,NBNN
  28. DO 201 J=1,NUMELG
  29. IF (NUM(I,J).EQ.0) GOTO 201
  30. IA=NUM(I,J)-NCTIN+1
  31. IF (IA.LT.1) GOTO 201
  32. IVOI(IA)=IVOI(IA)+1
  33. KON(IVOI(IA),IA)=J
  34. 201 CONTINUE
  35. 202 CONTINUE
  36. IF (ICLE.EQ.10) GOTO 501
  37. I=0
  38. 1 I=I+1
  39. IF (I.GT.NUMELG) GOTO 3
  40. I1=NUM(1,I)
  41. I2=NUM(2,I)
  42. I3=NUM(3,I)
  43. CALI=CAL(I1,I2,I3)
  44. IF (NBNN.EQ.3.AND.CALI.GE.QUAL) GOTO 1
  45. IF (NBNN.EQ.4.AND.NUM(4,I).NE.0) GOTO 1
  46. DO 4 IPOI=1,3
  47. IRP=NUM(IPOI,I)-NCTIN+1
  48. IF (IRP.LT.1) GOTO 4
  49. NM=IVOI(IRP)
  50. IF (NM.EQ.0) GOTO 4
  51. DO 2 JAUX=1,NM
  52. J=KON(JAUX,IRP)
  53. IF (J.GT.NUMELG) GOTO 2
  54. IF (NBNN.EQ.4.AND.NUM(4,J).NE.0) GOTO 2
  55. IF (I1.EQ.NUM(1,J)) GOTO 11
  56. IF (I1.EQ.NUM(2,J)) GOTO 21
  57. IF (I1.EQ.NUM(3,J)) GOTO 31
  58. IF (I2.EQ.NUM(1,J)) GOTO 41
  59. IF (I2.EQ.NUM(2,J)) GOTO 51
  60. IF (I2.EQ.NUM(3,J)) GOTO 61
  61. GOTO 2
  62. 11 IF (I2.EQ.NUM(3,J)) GOTO 12
  63. IF (I3.NE.NUM(2,J)) GOTO 2
  64. IAA=I1
  65. I1=I3
  66. I3=I2
  67. I2=IAA
  68. JJ=NUM(3,J)
  69. GOTO 100
  70. 12 JJ=NUM(2,J)
  71. GOTO 100
  72. 21 IF (I2.EQ.NUM(1,J)) GOTO 22
  73. IF (I3.NE.NUM(3,J)) GOTO 2
  74. IAA=I1
  75. I1=I3
  76. I3=I2
  77. I2=IAA
  78. JJ=NUM(1,J)
  79. GOTO 100
  80. 22 JJ=NUM(3,J)
  81. GOTO 100
  82. 31 IF (I2.EQ.NUM(2,J)) GOTO 32
  83. IF (I3.NE.NUM(1,J)) GOTO 2
  84. IAA=I1
  85. I1=I3
  86. I3=I2
  87. I2=IAA
  88. JJ=NUM(2,J)
  89. GOTO 100
  90. 32 JJ=NUM(1,J)
  91. GOTO 100
  92. 41 IF (I3.NE.NUM(3,J)) GOTO 2
  93. IAA=I1
  94. I1=I2
  95. I2=I3
  96. I3=IAA
  97. JJ=NUM(2,J)
  98. GOTO 100
  99. 51 IF (I3.NE.NUM(1,J)) GOTO 2
  100. IAA=I1
  101. I1=I2
  102. I2=I3
  103. I3=IAA
  104. JJ=NUM(3,J)
  105. GOTO 100
  106. 61 IF (I3.NE.NUM(2,J)) GOTO 2
  107. IAA=I1
  108. I1=I2
  109. I2=I3
  110. I3=IAA
  111. JJ=NUM(1,J)
  112. 100 CONTINUE
  113. IF (NBNN.EQ.3) GOTO 101
  114. C ON TENTE D'ASSEMBLER UN QUADRANGLE
  115. IF (IIMPI.EQ.2) WRITE (IOIMP,1013) I,J,I1,JJ,I2,I3
  116. 1013 FORMAT (' TEST QUADRANGLES AVEC LES TRIANGLES ',6I5)
  117. AN=ANG(I3,I1,JJ)
  118. IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
  119. AN=ANG(I1,JJ,I2)
  120. IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
  121. AN=ANG(JJ,I2,I3)
  122. IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
  123. AN=ANG(I2,I3,I1)
  124. IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
  125. C VA POUR UN QUADRANGLE
  126. NUM(1,I)=I1
  127. NUM(2,I)=JJ
  128. NUM(3,I)=I2
  129. NUM(4,I)=I3
  130. IF (IIMPI.NE.0) WRITE (IOIMP,1012) I,J,I1,JJ,I2,I3
  131. 1012 FORMAT (' REUNION DES TRIANGLES ',6I5)
  132. NUMELG=NUMELG-1
  133. IF (I.GT.J) I=I-1
  134. DO 102 K=J,NUMELG
  135. NUM(1,K)=NUM(1,K+1)
  136. NUM(2,K)=NUM(2,K+1)
  137. NUM(3,K)=NUM(3,K+1)
  138. NUM(4,K)=NUM(4,K+1)
  139. 102 CONTINUE
  140. * OCTOBRE 1987 IL FAUT AUSSI METTRE A JOUR KON
  141. DO 103 K1=1,ISUP
  142. DO 104 K2=1,IRANGE
  143. *>>>>> P.M. 16/11/90
  144. *+* IF (KON(K1,K2).GT.J) KON(K1,K2)=KON(K1,K2)-1
  145. IF (KON(K1,K2).GT.J) THEN
  146. KON(K1,K2)=KON(K1,K2)-1
  147. ELSE IF (KON(K1,K2).EQ.J) THEN
  148. IVOI(K2) = IVOI(K2) - 1
  149. DO 105 K1B = K1,IVOI(K2)
  150. KON(K1B,K2) = KON(K1B+1,K2)
  151. 105 CONTINUE
  152. END IF
  153. *<<<<<
  154. 104 CONTINUE
  155. 103 CONTINUE
  156. ICLE=6
  157. GOTO 1
  158. 101 IF (CALI.GE.QUAL.AND.NBNN.EQ.4) GOTO 2
  159. CALS=CAL(I1,JJ,I3)
  160. IF (CALS.LT.CALI) GOTO 2
  161. CALT=CAL(JJ,I2,I3)
  162. IF (CALT.LT.CALI) GOTO 2
  163. C ON PEUT COUPER SUIVANT LA DEUXIEME DIAGONALE
  164. NUM(1,I)=I1
  165. NUM(2,I)=JJ
  166. NUM(3,I)=I3
  167. NUM(1,J)=JJ
  168. NUM(2,J)=I2
  169. NUM(3,J)=I3
  170. IF (CALS.LT.QUAL.OR.CALT.LT.QUAL) ICLE=6
  171. GOTO 5
  172. 2 CONTINUE
  173. 4 CONTINUE
  174. IF (CALI.GE.QUAL) GOTO 5
  175. C C'EST L'ECHEC
  176. IF (IIMPI.EQ.1) WRITE (IOIMP,1005) I,I1,I2,I3,CALI
  177. 1005 FORMAT (' ELEMENT ',I5,' FORME DES NOEUDS SOMMETS ',3I5,' QUALITE
  178. # ',G12.5)
  179. IF (ICLE.NE.6) ICLE=5
  180. 5 CONTINUE
  181. GOTO 1
  182. 3 CONTINUE
  183. C DEPLACEMENT DES NOEUDS
  184. GOTO 560
  185. 501 CONTINUE
  186. IF (NUMINI.GT.NUMNP) RETURN
  187. DO 500 I=NUMINI,NUMNP
  188. IR=I-NCTIN+1
  189. LONG=IVOI(IR)
  190. IF (LONG.EQ.0) GOTO 500
  191. XGRAV=0.
  192. YGRAV=0.
  193. XNOMB=0.
  194. DO 502 J=1,LONG
  195. LEL=KON(J,IR)
  196. I1=NUM(1,LEL)
  197. I2=NUM(3,LEL)
  198. IF (I1.NE.I) GOTO 540
  199. I1=NUM(2,LEL)
  200. IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I2=NUM(4,LEL)
  201. GOTO 541
  202. 540 IF (I2.NE.I) GOTO 541
  203. I2=NUM(2,LEL)
  204. IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I1=NUM(4,LEL)
  205. 541 CONTINUE
  206. XCOF=1.
  207. XGRAV=XGRAV+XCOF*(X(1,I1)+X(1,I2))
  208. YGRAV=YGRAV+XCOF*(X(2,I1)+X(2,I2))
  209. XNOMB=XNOMB+2.*XCOF
  210. IF (NBNN.NE.4.OR.NUM(4,LEL).EQ.0) GOTO 502
  211. I5=NUM(1,LEL)+NUM(2,LEL)+NUM(3,LEL)+NUM(4,LEL)-I-I1-I2
  212. XGRAV=XGRAV+2.*XCOF*X(1,I5)
  213. YGRAV=YGRAV+2.*XCOF*X(2,I5)
  214. XNOMB=XNOMB+2.*XCOF
  215. 502 CONTINUE
  216. X(1,I)=XGRAV/XNOMB
  217. X(2,I)=YGRAV/XNOMB
  218. 500 CONTINUE
  219. DO 510 IAAUX=NUMINI,NUMNP
  220. I=NUMNP-IAAUX+NUMINI
  221. IR=I-NCTIN+1
  222. LONG=IVOI(IR)
  223. IF (LONG.EQ.0) GOTO 510
  224. XGRAV=0.
  225. YGRAV=0.
  226. XNOMB=0.
  227. DO 512 J=1,LONG
  228. LEL=KON(J,IR)
  229. I1=NUM(1,LEL)
  230. I2=NUM(3,LEL)
  231. IF (I1.NE.I) GOTO 550
  232. I1=NUM(2,LEL)
  233. IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I2=NUM(4,LEL)
  234. GOTO 551
  235. 550 IF (I2.NE.I) GOTO 551
  236. I2=NUM(2,LEL)
  237. IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I1=NUM(4,LEL)
  238. 551 CONTINUE
  239. XCOF=1.
  240. XGRAV=XGRAV+XCOF*(X(1,I1)+X(1,I2))
  241. YGRAV=YGRAV+XCOF*(X(2,I1)+X(2,I2))
  242. XNOMB=XNOMB+2.*XCOF
  243. IF (NBNN.NE.4.OR.NUM(4,LEL).EQ.0) GOTO 512
  244. I5=NUM(1,LEL)+NUM(2,LEL)+NUM(3,LEL)+NUM(4,LEL)-I-I1-I2
  245. XGRAV=XGRAV+2*XCOF*X(1,I5)
  246. YGRAV=YGRAV+2*XCOF*X(2,I5)
  247. XNOMB=XNOMB+2*XCOF
  248. 512 CONTINUE
  249. X(1,I)=XGRAV/XNOMB
  250. X(2,I)=YGRAV/XNOMB
  251. 510 CONTINUE
  252. RETURN
  253. 560 CONTINUE
  254. IF (IIMPI.EQ.1) WRITE (IOIMP,1011)
  255. 1011 FORMAT(' RECHERCHE DE LA QUALITE MINIMALE APRES DEPLACEMENT DES NO
  256. #EUDS')
  257. CALI=1.
  258. ISAUV=1
  259. I=0
  260. 520 I=I+1
  261. IF (I.GT.NUMELG) GOTO 590
  262. IF (NBNN.EQ.4.AND.NUM(4,I).NE.0) GOTO 530
  263. 591 CONTINUE
  264. I1=NUM(1,I)
  265. I2=NUM(2,I)
  266. I3=NUM(3,I)
  267. CALJ=CAL(I1,I2,I3)
  268. IF (CALJ.GE.CALI) GOTO 520
  269. ISAUV=I
  270. CALI=CALJ
  271. GOTO 520
  272. 590 CONTINUE
  273. I1=NUM(1,ISAUV)
  274. I2=NUM(2,ISAUV)
  275. I3=NUM(3,ISAUV)
  276. IF (IIMPI.EQ.1) WRITE (IOIMP,1005) ISAUV,I1,I2,I3,CALI
  277. NUM2=NUMELG
  278. RETURN
  279. C ON CONVERTIT LES QUADRANGLES APLATIS EN COUPLES DE TRIANGLES
  280. 530 CONTINUE
  281. I1=NUM(1,I)
  282. I2=NUM(2,I)
  283. I3=NUM(3,I)
  284. I4=NUM(4,I)
  285. ANG1=ANG(I4,I1,I2)
  286. IF (ANG1.GT.0..AND.ANG1.LT.2.6) GOTO 522
  287. 523 ICLE=6
  288. NUM(4,I)=0
  289. NUMELG=NUMELG+1
  290. NUM(1,NUMELG)=I1
  291. NUM(2,NUMELG)=I3
  292. NUM(3,NUMELG)=I4
  293. NUM(4,NUMELG)=0
  294. GOTO 591
  295. 522 ANG3=ANG(I2,I3,I4)
  296. IF (ANG3.LT.0..OR.ANG3.GT.2.6) GOTO 523
  297. 525 ANG2=ANG(I1,I2,I3)
  298. IF (ANG2.GT.0..AND.ANG2.LT.2.6) GOTO 526
  299. 527 NUM(4,I)=0
  300. ICLE=6
  301. NUM(3,I)=I4
  302. NUMELG=NUMELG+1
  303. NUM(1,NUMELG)=I2
  304. NUM(2,NUMELG)=I3
  305. NUM(3,NUMELG)=I4
  306. NUM(4,NUMELG)=0
  307. GOTO 591
  308. 526 ANG4=ANG(I3,I4,I1)
  309. IF (ANG4.LT.0..OR.ANG4.GT.2.6) GOTO 527
  310. GOTO 520
  311. END
  312.  
  313.  

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