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

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