1 : C HEXA SOURCE PV 07/10/08 21:15:09 5896 2 : C---------------------------------------------------------------------| 3 : C | 4 : SUBROUTINE HEXA(II,JJ,IF1,IF2,IGAGNE) 5 : C | 6 : C CETTE SUBROUTINE TENTE DE CREER UN HEXAEDRE A PARTIR | 7 : C DES QUADRANGLES IF1 ET IF2. | 8 : C - IGAGNE=1 EN CAS DE SUCCES | 9 : C - IGAGNE=0 EN CAS D'ECHEC | 10 : C | 11 : C---------------------------------------------------------------------| 12 : C 13 : IMPLICIT INTEGER(I-N) 14 : IMPLICIT REAL*8(A-H,O-Z) 15 : -INC TDEMAIT 16 : -INC CCOPTIO 17 : LOGICAL REPONS,FACET,SOLHEX,DIAGO,IN2,PLAN,dist2 18 : nfcini=nfcmax 19 : nptini=nptmax 20 : NPTSAU=NPTMAX 21 : C 22 : * WRITE(6,1000) 23 : 1000 FORMAT(' ----->>> HEXA <<<-----') 24 : C 25 : * 26 : * (1) VERIFICATION DE l'ANGLE du diedre 27 : * 28 : ANG=TETA(IF1,if2,ii,jj) 29 : if (ang.lt.-1.d0) return 30 : if (ang.gt.1.d0) goto 1500 31 : IGAGNE=0 32 : L1=0 33 : L2=0 34 : N3=0 35 : N4=0 36 : N5=0 37 : N6=0 38 : IF5=0 39 : IF6=0 40 : ICTF=0 41 : ICTV=0 42 : J1=IPRED(IF1,II) 43 : J2=ISUCC(IF1,JJ) 44 : K1=ISUCC(IF2,II) 45 : K2=IPRED(IF2,JJ) 46 : C 47 : C RECHERCHE DE LA FACETTE IF3 48 : C --------------------------- 49 : C 50 : IF3=IFACE3(K1,II,J1) 51 : * IF (IF3.NE.0) WRITE(6,1010)IF3 52 : 1010 FORMAT(' ** IF3=',I3) 53 : C 54 : IF (IF3.NE.0) THEN 55 : N3=1 56 : IF(NFC(4,IF3).EQ.0) goto 1500 57 : C LA FACETTE DOIT ETRE QUADRANGULAIRE 58 : * write (6,*) ' if3 trouvee',nfc(1,if3),nfc(2,if3), 59 : * # nfc(3,if3),nfc(4,if3) 60 : ANG=TETA(IF1,if3,j1,ii) 61 : if (ang.lt.-1.d0) then 62 : * write (6,*) ' hexa probleme 1' 63 : goto 1500 64 : endif 65 : ANG=TETA(IF2,if3,ii,k1) 66 : if (ang.lt.-1.d0) then 67 : * write (6,*) ' hexa probleme 2' 68 : goto 1500 69 : endif 70 : ENDIF 71 : IF(N3.NE.0) L1=ISUCC(IF3,J1) 72 : C 73 : C RECHERCHE DE LA FACETTE IF4 74 : C --------------------------- 75 : C 76 : IF4=IFACE3(J2,JJ,K2) 77 : * IF (IF4.NE.0) WRITE(6,1020)IF4 78 : 1020 FORMAT(' ** IF4=',I3) 79 : C 80 : IF (IF4.NE.0) THEN 81 : N4=1 82 : IF(NFC(4,IF4).EQ.0) goto 1500 83 : C LA FACETTE DOIT ETRE QUADRANGULAIRE 84 : * write (6,*) ' if4 trouvee',nfc(1,if4),nfc(2,if4), 85 : * # nfc(3,if4),nfc(4,if4) 86 : ANG=TETA(IF1,if4,jj,j2) 87 : if (ang.lt.-1.d0) then 88 : * write (6,*) ' hexa probleme 3' 89 : goto 1500 90 : endif 91 : ANG=TETA(IF2,if4,k2,jj) 92 : if (ang.lt.-1.d0) then 93 : * write (6,*) ' hexa probleme 4' 94 : goto 1500 95 : endif 96 : ENDIF 97 : IF(N4.NE.0) L2=IPRED(IF4,J2) 98 : C 99 : C 100 : C RECHERCHE DE LA FACETTE IF5 101 : C --------------------------- 102 : C 103 : IF(L1*L2.NE.0) THEN 104 : IF5=IFACE4(L1,L2,K1,K2) 105 : if (if5.lt.0) then 106 : * write (6,*) ' if5 trouve 3pts ' 107 : return 108 : endif 109 : ELSEIF(L1.NE.0) THEN 110 : IF5=IFACE3(L1,K1,K2) 111 : ELSEIF(L2.NE.0) THEN 112 : IF5=IFACE3(L2,K1,K2) 113 : ELSE 114 : ANG=TETA(IF2,NOISIN(K1,K2,IF2),K1,K2) 115 : IF (ANG.GT.-1.d0) IF5=NOISIN(K1,K2,IF2) 116 : endif 117 : * IF (IF5.NE.0) WRITE(6,1030)IF5 118 : 1030 FORMAT(' ** IF5=',I3) 119 : C 120 : IF (IF5.NE.0) THEN 121 : N5=1 122 : IF(NFC(4,IF5).EQ.0) RETURN 123 : C LA FACETTE DOIT ETRE QUADRANGULAIRE 124 : * write (6,*) ' if5 trouvee',if5,nfc(1,if5),nfc(2,if5), 125 : * # nfc(3,if5),nfc(4,if5) 126 : ENDIF 127 : IF (IF5.NE.0) L1=ISUCC(IF5,K1) 128 : IF (IF5.NE.0) L2=IPRED(IF5,K2) 129 : C 130 : C 131 : C 132 : C RECHERCHE DE LA FACETTE IF6 133 : C --------------------------- 134 : C 135 : IF(L1*l2.NE.0) THEN 136 : IF6=IFACE4(L1,L2,J1,J2) 137 : if (if6.lt.0) then 138 : * write (6,*) ' if6 trouve 3pts ' 139 : goto 1500 140 : endif 141 : ELSEIF(L1.NE.0) THEN 142 : IF6=IFACE3(L1,J1,J2) 143 : ELSEIF(L2.NE.0) THEN 144 : IF6=IFACE3(L2,J1,J2) 145 : ELSE 146 : ANG=TETA(IF1,NOISIN(J2,J1,IF1),J2,J1) 147 : IF (ANG.GT.-1.d0) IF6=NOISIN(J2,J1,if1) 148 : endif 149 : * IF (IF6.NE.0) WRITE(6,1040)IF6 150 : 1040 FORMAT(' ** IF5=',I3) 151 : C 152 : IF (IF6.NE.0) THEN 153 : N6=1 154 : IF(NFC(4,IF6).EQ.0) goto 1500 155 : C LA FACETTE DOIT ETRE QUADRANGULAIRE 156 : * write (6,*) ' if6 trouvee',if6,nfc(1,if6),nfc(2,if6), 157 : * # nfc(3,if6),nfc(4,if6) 158 : ENDIF 159 : IF (IF6.NE.0) L1=IPRED(IF6,J1) 160 : IF (IF6.NE.0) L2=ISUCC(IF6,J2) 161 : C 162 : * 163 : * (1) VERIFICATION DES ANGLES AVEC FACETTES ADJACENTES (MINI 90) 164 : * 165 : IF (N6.EQ.0) THEN 166 : ANG=TETA(IF1,NOISIN(J2,J1,IF1),J2,J1) 167 : * write (6,*) 'facette 1 angle 1',ang 168 : IF (ANG.GT.-1.d0) goto 1500 169 : ENDIF 170 : IF (N3.EQ.0) THEN 171 : ANG=TETA(IF1,NOISIN(J1,II,IF1),J1,II) 172 : * write (6,*) 'facette 1 angle 2',ang 173 : IF (ANG.GT.-1.d0) goto 1500 174 : ENDIF 175 : IF (N4.EQ.0) THEN 176 : ANG=TETA(IF1,NOISIN(JJ,J2,IF1),JJ,J2) 177 : * write (6,*) 'facette 1 angle 3',ang 178 : IF (ANG.GT.-1.d0) goto 1500 179 : ENDIF 180 : IF (N5.EQ.0) THEN 181 : ANG=TETA(IF2,NOISIN(K1,K2,IF2),K1,K2) 182 : * write (6,*) 'facette 2 angle 1',ang 183 : IF (ANG.GT.-1.d0) goto 1500 184 : ENDIF 185 : IF (N4.EQ.0) THEN 186 : ANG=TETA(IF2,NOISIN(K2,JJ,IF2),K2,JJ) 187 : * write (6,*) 'facette 2 angle 2',ang 188 : IF (ANG.GT.-1.d0) goto 1500 189 : ENDIF 190 : IF (N3.EQ.0) THEN 191 : ANG=TETA(IF2,NOISIN(II,K1,IF2),II,K1) 192 : * write (6,*) 'facette 2 angle 3',ang 193 : IF (ANG.GT.-1.d0) goto 1500 194 : ENDIF 195 : * a ameliorer plus tard 196 : C 197 : C 198 : C Construction des deux points supplementaires (si necessaire) 199 : C 200 : IF(L1.EQ.0) THEN 201 : L1=NPTMAX+1 202 : NPTMAX=L1 203 : C 204 : C DETERMINATION DES COORDONNEES DU NOUVEAU POINT L1 205 : C ------------------------------------------------- 206 : xj1=xyz(1,j1)-xyz(1,ii) 207 : yj1=xyz(2,j1)-xyz(2,ii) 208 : zj1=xyz(3,j1)-xyz(3,ii) 209 : vj1=xj1**2+yj1**2+zj1**2 210 : xk1=xyz(1,k1)-xyz(1,ii) 211 : yk1=xyz(2,k1)-xyz(2,ii) 212 : zk1=xyz(3,k1)-xyz(3,ii) 213 : vk1=xk1**2+yk1**2+zk1**2 214 : scal=xj1*xk1+yj1*yk1+zj1*zk1 215 : xyz(1,l1)=(xyz(1,k1)+xj1-scal*xk1/vk1+ 216 : * xyz(1,j1)+xk1-scal*xj1/vj1)*0.5d0 217 : xyz(2,l1)=(xyz(2,k1)+yj1-scal*yk1/vk1+ 218 : * xyz(2,j1)+yk1-scal*yj1/vj1)*0.5d0 219 : xyz(3,l1)=(xyz(3,k1)+zj1-scal*zk1/vk1+ 220 : * xyz(3,j1)+zk1-scal*zj1/vj1)*0.5d0 221 : DO 150 I=1,3 222 : ****** XYZ(I,L1)=(XYZ(I,L1)+XYZ(I,J1)+XYZ(I,K1)-XYZ(I,II))*0.5d0 223 : XYZ(I,L1)= XYZ(I,J1)+XYZ(I,K1)-XYZ(I,II) 224 : 150 CONTINUE 225 : if (L2.ne.0) then 226 : do 151 i=1,3 227 : XYZ(I,L1)=(XYZ(I,L1)+XYZ(I,J1)+XYZ(I,L2)-XYZ(I,J2)+ 228 : * XYZ(I,K1)+XYZ(I,L2)-XYZ(I,K2))/3.d0 229 : 151 continue 230 : endif 231 : XYZ(4,L1)=(XYZ(4,J1)+XYZ(4,K1)+XYZ(4,II))/3.d0 231 : CALL DIST(L1,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L2,0,0,0) 232 : IF (IOK.EQ.0) THEN 233 : * C'est rate 234 : nptmax=nptsau 235 : goto 1500 236 : C l1=kp 237 : C write (6,*) 'hexa point assimile 1 ',kp 238 : C if (diago(l1,j1,0.95D0)) then 239 : C* write (6,*) ' diago quad',l1,j1 240 : C NPTMAX=NPTsau 241 : C goto 1500 242 : C endif 243 : C if (diago(l1,k1,0.95D0)) then 244 : C* write (6,*) ' diago quad',l1,k1 245 : C NPTMAX=NPTsau 246 : C goto 1500 247 : C endif 248 : ENDIF 249 : * if (dist2(l1)) then 250 : * nptmax=nptsau 251 : * return 252 : * endif 253 : XYZ(1,L1+1)=XYZ(1,JJ)+1.35*(XYZ(1,L1)-XYZ(1,JJ)) 254 : XYZ(2,L1+1)=XYZ(2,JJ)+1.35*(XYZ(2,L1)-XYZ(2,JJ)) 255 : XYZ(3,L1+1)=XYZ(3,JJ)+1.35*(XYZ(3,L1)-XYZ(3,JJ)) 256 : XYZ(4,L1+1)=XYZ(4,JJ)+1.35*(XYZ(4,L1)-XYZ(4,JJ)) 257 : * IF (.NOT.IN2(jj,L1+1,nfcini)) THEN 258 : * write (6,*) ' in incorrect 1' 259 : * nptmax=nptsau 260 : * goto 1500 261 : * ENDIF 262 : * if (dist2(l1+1)) then 263 : * nptmax=nptsau 264 : * return 265 : * endif 265 : CALL DIST(L1+1,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L1,L2,0,0) 266 : IF (IOK.EQ.0) THEN 267 : * C'est encore rate 268 : NPTMAX=NPTSAU 269 : write (6,*) 'point mal place 1.1',kp 270 : goto 1500 271 : ENDIF 272 : ENDIF 273 : * verif que l1 appartient bien a n3 n5 et n6 si ils existent 274 : if (n3.ne.0) then 275 : if (L1.ne.ISUCC(IF3,J1)) then 276 : * write (6,*) ' faces ne correspondent pas ' 277 : nptmax=nptsau 278 : goto 1500 279 : endif 280 : endif 281 : if (n5.ne.0) then 282 : if (L1.ne.ISUCC(IF5,K1)) then 283 : * write (6,*) ' faces ne correspondent pas ' 284 : nptmax=nptsau 285 : goto 1500 286 : endif 287 : endif 288 : if (n6.ne.0) then 289 : if (L1.ne.IPRED(IF6,J1)) then 290 : * write (6,*) ' faces ne correspondent pas ' 291 : nptmax=nptsau 292 : goto 1500 293 : endif 294 : endif 295 : IF(L2.EQ.0) THEN 296 : L2=NPTMAX+1 297 : NPTMAX=L2 298 : C 299 : C DETERMINATION DES COORDONNEES DU NOUVEAU POINT L2 300 : C ------------------------------------------------- 301 : xj2=xyz(1,j2)-xyz(1,jj) 302 : yj2=xyz(2,j2)-xyz(2,jj) 303 : zj2=xyz(3,j2)-xyz(3,jj) 304 : vj2=xj2**2+yj2**2+zj2**2 305 : xk2=xyz(1,k2)-xyz(1,jj) 306 : yk2=xyz(2,k2)-xyz(2,jj) 307 : zk2=xyz(3,k2)-xyz(3,jj) 308 : vk2=xk2**2+yk2**2+zk2**2 309 : scal=xj2*xk2+yj2*yk2+zj2*zk2 310 : xyz(1,l2)=(xyz(1,k2)+xj2-scal*xk2/vk2+ 311 : * xyz(1,j2)+xk2-scal*xj2/vj2)*0.5d0 312 : xyz(2,l2)=(xyz(2,k2)+yj2-scal*yk2/vk2+ 313 : * xyz(2,j2)+yk2-scal*yj2/vj2)*0.5d0 314 : xyz(3,l2)=(xyz(3,k2)+zj2-scal*zk2/vk2+ 315 : * xyz(3,j2)+zk2-scal*zj2/vj2)*0.5d0 316 : DO 170 I=1,3 317 : ********** XYZ(I,L2)=(XYZ(I,L2)+XYZ(I,J2)+XYZ(I,K2)-XYZ(I,JJ))*0.5d0 318 : XYZ(I,L2)= XYZ(I,J2)+XYZ(I,K2)-XYZ(I,JJ) 319 : 170 CONTINUE 320 : if (L1.ne.0) then 321 : do 171 i=1,3 322 : XYZ(I,L2)=(XYZ(I,L2)+XYZ(I,J2)+XYZ(I,L1)-XYZ(I,J1)+ 323 : * XYZ(I,L1)+XYZ(I,K2)-XYZ(I,K1))/3.d0 324 : 171 continue 325 : endif 326 : XYZ(4,L2)=(XYZ(4,J2)+XYZ(4,K2)+XYZ(4,JJ))/3.d0 326 : CALL DIST(L2,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L1,0,0,0) 327 : IF (IOK.EQ.0) THEN 328 : * C'est rate 329 : nptmax=nptsau 330 : goto 1500 331 : C l2=kp 332 : C write (6,*) 'hexa point assimile 2 ',kp 333 : C if (diago(l2,j2,0.95d0)) then 334 : C* write (6,*) ' diago quad',l1,j1 335 : C NPTMAX=NPTsau 336 : C goto 1500 337 : C endif 338 : C if (diago(l2,k2,0.95d0)) then 339 : C* write (6,*) ' diago quad',l2,k2 340 : C NPTMAX=NPTsau 341 : C goto 1500 342 : C endif 343 : C if (diago(l2,l1,0.95d0)) then 344 : C* write (6,*) ' diago quad',l2,l1 345 : C NPTMAX=NPTsau 346 : C goto 1500 347 : C endif 348 : ENDIF 349 : * if (dist2(l2)) then 350 : * nptmax=nptsau 351 : * return 352 : * endif 353 : XYZ(1,L2+1)=XYZ(1,II)+1.35*(XYZ(1,L2)-XYZ(1,II)) 354 : XYZ(2,L2+1)=XYZ(2,II)+1.35*(XYZ(2,L2)-XYZ(2,II)) 355 : XYZ(3,L2+1)=XYZ(3,II)+1.35*(XYZ(3,L2)-XYZ(3,II)) 356 : XYZ(4,L2+1)=XYZ(4,II)+1.35*(XYZ(4,L2)-XYZ(4,II)) 357 : * IF (.NOT.IN2(ii,L2+1,nfcini)) THEN 358 : * write (6,*) ' in incorrect 2' 359 : * nptmax=nptsau 360 : * goto 1500 361 : * ENDIF 362 : * if (dist2(l2+1)) then 363 : * nptmax=nptsau 364 : * return 365 : * endif 365 : CALL DIST(L2+1,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L1,L2,0,0) 366 : IF (IOK.EQ.0) THEN 367 : ** C'est encore rate 368 : NPTMAX=NPTSAU 369 : write (6,*) 'point mal place 2.2',kp 370 : goto 1500 371 : ENDIF 372 : ENDIF 373 : * verif que l2 appartient bien a n4 n5 et n6 si ils existent 374 : if (n4.ne.0) then 375 : if (L2.ne.IPRED(IF4,J2)) then 376 : * write (6,*) ' faces ne correspondent pas ' 377 : nptmax=nptsau 378 : goto 1500 379 : endif 380 : endif 381 : if (n5.ne.0) then 382 : if (L2.ne.IPRED(IF5,K2)) then 383 : * write (6,*) ' faces ne correspondent pas ' 384 : nptmax=nptsau 385 : goto 1500 386 : endif 387 : endif 388 : if (n6.ne.0) then 389 : if (L2.ne.ISUCC(IF6,J2)) then 390 : * write (6,*) ' faces ne correspondent pas ' 391 : nptmax=nptsau 392 : goto 1500 393 : endif 394 : endif 395 : IF (DIAGO(L1,L2,0.95D0)) THEN 396 : * write (6,*) ' diago quad',L1,L2 397 : NPTMAX=NPTsau 398 : goto 1500 399 : ENDIF 400 : C 401 : C 402 : C 403 : C CONSTRUCTION DU CUBE 404 : C -------------------- 405 : C 406 : IF (IF3.EQ.0) THEN 407 : C 408 : C CREATION DE LA FACETTE IF3 409 : C -------------------------- 410 : IF3=IFACE4(IPRED(IF1,II),II,ISUCC(IF2,II),L1) 411 : if (if3.lt.0) then 412 : * write (6,*) ' if3 trouve 3pts ' 413 : nfcmax=nfcini 414 : nptmax=nptini 415 : return 416 : elseif (if3.eq.0) then 417 : NFCMAX=NFCMAX+1 418 : IF3=NFCMAX 419 : ICTF=ICTF+1 420 : C 421 : NFC(1,IF3)=IPRED(IF1,II) 422 : NFC(2,IF3)=II 423 : NFC(3,IF3)=ISUCC(IF2,II) 424 : NFC(4,IF3)=L1 425 : C 426 : ENDIF 427 : ENDIF 428 : C 429 : C 430 : IF (IF4.EQ.0) THEN 431 : C 432 : C CREATION DE LA FACETTE IF4 433 : C -------------------------- 434 : IF4=IFACE4(JJ,ISUCC(IF1,JJ),L2,IPRED(IF2,JJ)) 435 : if (if4.lt.0) then 436 : * write (6,*) ' if4 trouve 3pts ' 437 : nfcmax=nfcini 438 : nptmax=nptini 439 : return 440 : elseif (if4.eq.0) then 441 : NFCMAX=NFCMAX+1 442 : IF4=NFCMAX 443 : ICTF=ICTF+1 444 : C 445 : NFC(1,IF4)=JJ 446 : NFC(2,IF4)=ISUCC(IF1,JJ) 447 : NFC(3,IF4)=L2 448 : NFC(4,IF4)=IPRED(IF2,JJ) 449 : C 450 : ENDIF 451 : ENDIF 452 : C 453 : C 454 : IF (IF5.EQ.0) THEN 455 : C 456 : C CREATION DE LA FACETTE IF5 457 : C -------------------------- 458 : IF5=IFACE4(l1,k1,k2,l2) 459 : if (if5.lt.0) then 460 : * write (6,*) ' if5 trouve 3pts ' 461 : nfcmax=nfcini 462 : nptmax=nptini 463 : return 464 : elseif (if5.eq.0) then 465 : NFCMAX=NFCMAX+1 466 : IF5=NFCMAX 467 : ICTF=ICTF+1 468 : C 469 : NFC(1,IF5)=L1 470 : NFC(2,IF5)=K1 471 : NFC(3,IF5)=K2 472 : NFC(4,IF5)=L2 473 : C 474 : C 475 : ENDIF 476 : ENDIF 477 : IF (IF6.EQ.0) THEN 478 : C 479 : C CREATION DE LA FACETTE IF6 480 : C -------------------------- 481 : IF6=IFACE4(j1,l1,l2,j2) 482 : if (if6.lt.0) then 483 : * write (6,*) ' if6 trouve 3pts ' 484 : nfcmax=nfcini 485 : nptmax=nptini 486 : return 487 : elseif (if6.eq.0) then 488 : NFCMAX=NFCMAX+1 489 : IF6=NFCMAX 490 : ICTF=ICTF+1 491 : C 492 : NFC(1,IF6)=J1 493 : NFC(2,IF6)=L1 494 : NFC(3,IF6)=L2 495 : NFC(4,IF6)=J2 496 : C 497 : C 498 : ENDIF 499 : ENDIF 500 : C 501 : C ON ENLEVE LES FACETTES IF1, IF2 ET IF3 502 : C -------------------------------------- 502 : CALL REPSUB(IF1) 502 : CALL REPSUB(IF2) 502 : CALL REPSUB(IF3) 502 : CALL REPSUB(IF4) 502 : CALL REPSUB(IF5) 502 : CALL REPSUB(IF6) 503 : C 504 : C LE VOLUME CREE EST-IL VALIDE ? 505 : C ------------------------------ 506 : IF (.NOT.PLAN(IF3)) GOTO 160 507 : * write (6,*) ' plan(if3) passe' 508 : IF (.NOT.PLAN(IF4)) GOTO 160 509 : * write (6,*) ' plan(if4) passe' 510 : IF (.NOT.PLAN(IF5)) GOTO 160 511 : * write (6,*) ' plan(if5) passe' 512 : IF (.NOT.PLAN(IF6)) GOTO 160 513 : * write (6,*) ' plan(if6) passe' 514 : IF (.NOT.FACET(IF3)) GOTO 160 515 : * write (6,*) ' facet(if3) passe' 516 : IF (.NOT.FACET(IF4)) GOTO 160 517 : * write (6,*) ' facet(if4) passe' 518 : IF (.NOT.FACET(IF5)) GOTO 160 519 : * write (6,*) ' facet(if5) passe' 520 : IF (.NOT.FACET(IF6)) GOTO 160 521 : * write (6,*) ' facet(if6) passe' 522 : IF (.NOT.SOLHEX(IF1,IF2,IF3,IF4,IF5,IF6)) GOTO 160 523 : * write (6,*) ' solhex passe' 524 : * 525 : * VERIFICATION TAILLE 526 : IF (N3.EQ.0.AND.N5.EQ.0) THEN 527 : KF1=IPRED(IF1,II) 528 : KF2=ISUCC(IF2,II) 529 : DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2 530 : # +(XYZ(2,KF1)-XYZ(2,KF2))**2 531 : # +(XYZ(3,KF1)-XYZ(3,KF2))**2 532 : DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2) 533 : IF (DNORM.GT.DTEST) GOTO 160 534 : ENDIF 535 : IF (N4.EQ.0.AND.N5.EQ.0) THEN 536 : KF1=IPRED(IF2,JJ) 537 : KF2=ISUCC(IF1,JJ) 538 : DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2 539 : # +(XYZ(2,KF1)-XYZ(2,KF2))**2 540 : # +(XYZ(3,KF1)-XYZ(3,KF2))**2 541 : DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2) 542 : IF (DNORM.GT.DTEST) GOTO 160 543 : ENDIF 544 : * write (6,*) 'hexa a cree un cube numero nfacet ',nvol+1,nfacet 545 : C 546 : C LE VOLUME CREE EST VALIDE | 547 : C --------------------------- 548 : C MEMORISATION DU VOLUME IF1, IF2, IF3, IF4 ET IF5 549 : C ------------------------------------------------ 550 : NVOL=NVOL+1 551 : IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL 552 : IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL 553 : IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL 554 : IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL 555 : IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL 556 : IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL 557 : IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL 558 : IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL 559 : IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL 560 : IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL 561 : IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL 562 : IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL 563 : IVOL(9,NVOL)=20 564 : IVOL(1,NVOL)=II 565 : IVOL(2,NVOL)=JJ 566 : IVOL(3,NVOL)=J2 567 : IVOL(4,NVOL)=J1 568 : IVOL(5,NVOL)=K1 569 : IVOL(6,NVOL)=K2 570 : IVOL(7,NVOL)=L2 571 : IVOL(8,NVOL)=L1 572 : C 573 : * WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9) 574 : if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,8) 575 : 1100 FORMAT(' HEXA facettes ',i5,' cub8 ',8i5) 576 : C 577 : * DO 150 J=1,NPTMAX 578 : * WRITE(6,1110)J,(NPF(I,J),I=1,40) 579 : *1110 FORMAT(I4,4X,40I3) 580 : *150 CONTINUE 581 : C 582 : IGAGNE=1 583 : C 584 : RETURN 585 : C 586 : 160 CONTINUE 587 : * write (6,*) ' probleme en validant le cube ' 588 : C 589 : C LE VOLUME CREE N'EST PAS VALIDE: IL FAUT DONC DETRUIRE LES FACETT 590 : C CREEES. --------------------------------------------------------- 590 : CALL REPSUB(IF1) 590 : CALL REPSUB(IF2) 590 : CALL REPSUB(IF3) 590 : CALL REPSUB(IF4) 590 : CALL REPSUB(IF5) 590 : CALL REPSUB(IF6) 591 : C 592 : NFCMAX=NFCMAX-ICTF 593 : C 594 : NPTMAX=NPTSAU 595 : 1500 continue 596 : * maintenant on essaye un prisme 597 : NPTMAX=NPTSAU 597 : * call prism1(II,JJ,IF1,IF2,IGAGNE) 598 : return 599 : end 600 : 601 : 602 : 603 : 604 :
© Cast3M 2003 - All rights reserved.
Disclaimer