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 :
© Cast3M 2003 - All rights reserved.
Disclaimer