1 : C COM433 SOURCE FANDEUR 13/01/29 21:15:14 7683 2 : C---------------------------------------------------------------------| 3 : C | 4 : SUBROUTINE COM433(II,MF1,MF2,MF3,IGAGNE) 5 : C | 6 : C CETTE SUBROUTINE TENTE DE CREER 1 PYRAMIDE ET 2 TETRAEDRES | 7 : C A PARTIR DU QUADRANGLE IF1 ET DES TRIANGLES IF2 ET IF3 EN | 8 : C CREANT UN POINT CENTRAL SUPPLEMENTAIRE | 9 : C - IGAGNE=1 EN CAS DE SUCCES | 10 : C - IGAGNE=0 EN CAS D'ECHEC | 11 : C | 12 : C---------------------------------------------------------------------| 13 : C 14 : IMPLICIT INTEGER(I-N) 15 : IMPLICIT REAL*8(A-H,O-Z) 16 : -INC TDEMAIT 17 : -INC CCOPTIO 18 : LOGICAL REPONS,FACET,SOLPYR,SOLTET,IN2,diago 19 : nfcini=nfcmax 20 : nptini=nptmax 21 : nvini=nvol 22 : ICTP=0 23 : ipin = 0 24 : C 25 : C METTRE LES FACES DANS L'ORDRE 26 : IF1=MF1 27 : IP=ISUCC(IF1,II) 28 : IF (IP.EQ.IPRED(MF2,II)) IF2=MF2 29 : IF (IP.EQ.IPRED(MF3,II)) IF2=MF3 30 : IP=ISUCC(IF2,II) 31 : IF (IP.EQ.IPRED(MF2,II)) IF3=MF2 32 : IF (IP.EQ.IPRED(MF3,II)) IF3=MF3 33 : * WRITE(6,1000)IF1,IF2,IF3 34 : 1000 FORMAT(' COM433 IF1=',I5,' IF2=',I5,' IF3=',I5) 35 : C 36 : ICTF=0 37 : ICTV=0 38 : C 39 : C 40 : C CREATION DU POINT CENTRAL : IP 41 : C ------------------------------ 42 : IP1=II 43 : IP2=ISUCC(IF1,IP1) 44 : IP3=ISUCC(IF1,IP2) 45 : IP4=ISUCC(IF1,IP3) 46 : ICTP=1 47 : NPTMAX=NPTMAX+1 48 : IP=NPTMAX 49 : C 50 : DO 100 I=1,4 51 : * XYZ(I,IP)=(XYZ(I,IP1)+XYZ(I,IP2)+XYZ(I,IP3) 52 : * # +XYZ(I,IP4))/4. 53 : XYZ(I,IP)=(XYZ(I,IP2)+XYZ(I,IP4))/2. 54 : 100 CONTINUE 55 : JP1=II 56 : JP2=ISUCC(IF2,JP1) 57 : JP3=ISUCC(IF2,JP2) 58 : C 59 : DO 102 I=1,4 60 : XYZ(I,IP)=XYZ(I,IP)+ 61 : # (XYZ(I,JP2)+XYZ(I,JP3))/2. 62 : 102 CONTINUE 63 : KP1=II 64 : KP2=ISUCC(IF3,KP1) 65 : KP3=ISUCC(IF3,KP2) 66 : C 67 : DO 104 I=1,4 68 : XYZ(I,IP)=(XYZ(I,IP)+ 69 : # (XYZ(I,KP2)+XYZ(I,KP3))/2.)/3. 70 : 104 CONTINUE 71 : DO 103 I=1,3 72 : XYZ(I,IP)=XYZ(I,II)+expcom*(XYZ(I,IP)-XYZ(I,II)) 73 : 103 CONTINUE 74 : C 75 : * WRITE(6,1010)IP,(XYZ(I,IP),I=1,4) 76 : 1010 FORMAT(' POINT:',I3,':',4F7.2) 77 : C 78 : * verif des volumes 79 : if ((vol(ip,ii,ip2,ip4).gt.0).or. 80 : > (vol(ip,ii,jp2,jp3).gt.0).or. 81 : > (vol(ip,ii,kp2,kp3).gt.0)) then 82 : write (6,*) ' com433 volume positif ' 83 : nptmax=nptini 84 : return 85 : endif 86 : C 86 : CALL DIST(IP,JP,GL,IOK,IP1,IP2,IP3,IP4,JP2,JP3,KP2,KP3,0,0) 87 : IF (IOK.EQ.0) THEN 88 : NPTMAX=NPTini 89 : RETURN 90 : ICTP=0 91 : NPTMAX=NPTMAX-1 92 : IP=JP 93 : return 94 : * WRITE (6,*) ' COM433 POINT ASSIMILE ',JP 95 : ENDIF 96 : REPONS=IN2(ii,IP,nfcini) 97 : IF (REPONS) GOTO 110 98 : NPTMAX=NPTini 99 : RETURN 100 : C 101 : 110 CONTINUE 102 : C 103 : C CREATION D'UNE PYRAMIDE : IF1+IP 104 : C -------------------------------- 105 : IP1=ISUCC(IF1,II) 106 : IP2=ISUCC(IF1,IP1) 107 : IP3=ISUCC(IF1,IP2) 108 : * recherche existence de la face 109 : jf1=IFACE3(ip,ii,ip1) 110 : * IF (jf1.ne.0) write (6,*) ' com433 facette assimilee' 111 : IF (jf1.eq.0) THEN 112 : nfcmax=nfcmax+1 113 : jf1=nfcmax 114 : NFC(1,jf1)=ip 115 : NFC(2,jf1)=ii 116 : NFC(3,jf1)=ip1 117 : NFC(4,jf1)=0 118 : elseif (NFC(4,jf1).ne.0.or.ipred(jf1,ii).ne.ip1) then 119 : jf1=0 120 : endif 121 : * write (6,*) ' com433 jf1 passe ',jf1 122 : C 123 : * recherche existence de la face 124 : jf2=IFACE3(ip,ip1,ip2) 125 : * IF (jf2.ne.0) write (6,*) ' com433 facette assimilee' 126 : IF (jf2.eq.0) THEN 127 : nfcmax=nfcmax+1 128 : jf2=nfcmax 129 : NFC(1,jf2)=ip 130 : NFC(2,jf2)=ip1 131 : NFC(3,jf2)=ip2 132 : NFC(4,jf2)=0 133 : elseif (NFC(4,jf2).ne.0.or.ipred(jf2,ip).ne.ip1) then 134 : jf2=0 135 : endif 136 : if (NFC(4,jf2).ne.0) jf2=0 137 : * write (6,*) ' com433 jf2 passe ',jf2 138 : C 139 : * recherche existence de la face 140 : jf3=IFACE3(ip,ip2,ip3) 141 : * IF (jf3.ne.0) write (6,*) ' com433 facette assimilee' 142 : IF (jf3.eq.0) THEN 143 : nfcmax=nfcmax+1 144 : jf3=nfcmax 145 : NFC(1,jf3)=ip 146 : NFC(2,jf3)=ip2 147 : NFC(3,jf3)=ip3 148 : NFC(4,jf3)=0 149 : elseif (NFC(4,jf3).ne.0.or.ipred(jf3,ip).ne.ip2) then 150 : jf3=0 151 : endif 152 : * write (6,*) ' com433 jf3 passe ',jf3 153 : C 154 : * recherche existence de la face 155 : jf4=IFACE3(ip,ip3,ii) 156 : * IF (jf4.ne.0) write (6,*) ' com433 facette assimilee' 157 : IF (jf4.eq.0) THEN 158 : nfcmax=nfcmax+1 159 : jf4=nfcmax 160 : NFC(1,jf4)=ip 161 : NFC(2,jf4)=ip3 162 : NFC(3,jf4)=ii 163 : NFC(4,jf4)=0 164 : elseif (NFC(4,jf4).ne.0.or.ipred(jf4,ip).ne.ip3) then 165 : jf4=0 166 : endif 167 : if (NFC(4,jf4).ne.0) jf4=0 168 : * write (6,*) ' com433 jf4 passe ',jf4 169 : C 170 : if (diago(ip,ii,diacrd)) then 171 : jf4=0 172 : jf1=0 173 : endif 174 : if (diago(ip,ip1,diacrd)) then 175 : * write (6,*) ' com433 jf4 echec diago - 1 ',ip,ip1 176 : jf1=0 177 : jf2=0 178 : endif 179 : if (diago(ip,ip2,diacrd)) then 180 : * write (6,*) ' com433 jf4 echec diago - 2 ',ip,ip2 181 : jf2=0 182 : jf3=0 183 : endif 184 : if (diago(ip,ip3,diacrd)) then 185 : * write (6,*) ' com433 jf4 echec diago - 3 ',ip,ip3 186 : jf3=0 187 : jf4=0 188 : endif 189 : if (jf1*jf2*jf3*jf4.eq.0) then 190 : * write (6,*) 'com433 impossibilite ' 191 : nfcmax=nfcini 192 : jf1=0 193 : jf2=0 194 : jf3=0 195 : jf4=0 196 : goto 131 197 : endif 197 : CALL REPSUB(IF1) 197 : CALL REPSUB(JF1) 197 : CALL REPSUB(JF2) 197 : CALL REPSUB(JF3) 197 : CALL REPSUB(JF4) 198 : C 199 : C LE VOLUME CREE EST-IL VALIDE ? 200 : C ------------------------------ 201 : IF (.not.SOLPYR(IF1,JF1,JF2,JF3,JF4)) GOTO 129 202 : IF (.NOT.FACET(jf1)) GOTO 129 203 : IF (.NOT.FACET(jf2)) GOTO 129 204 : IF (.NOT.FACET(jf3)) GOTO 129 205 : IF (.NOT.FACET(jf4)) GOTO 129 206 : goto 130 207 : C 208 : C LE VOLUME EST INVALIDE 209 : C ---------------------- 210 : 129 continue 211 : * write (6,*) ' solpyr 1 invalide' 212 : NFCMAX=NFCini 212 : CALL REPSUB(JF4) 212 : CALL REPSUB(JF3) 212 : CALL REPSUB(JF2) 212 : CALL REPSUB(JF1) 212 : CALL REPSUB(IF1) 213 : jf1=0 214 : jf2=0 215 : jf3=0 216 : jf4=0 217 : goto 131 218 : C 219 : 130 CONTINUE 220 : C 221 : C MEMORISATION DU VOLUME OBTENU : IF1, JF1, JF2, JF3 ET JF4 222 : C --------------------------------------------------------- 223 : ICTV=ICTV+1 224 : NVOL=NVOL+1 225 : IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL 226 : IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL 227 : IF (NFV(1,JF1).EQ.0) NFV(1,JF1)=NVOL 228 : IF (NFV(1,JF1).NE.NVOL) NFV(2,JF1)=NVOL 229 : IF (NFV(1,JF2).EQ.0) NFV(1,JF2)=NVOL 230 : IF (NFV(1,JF2).NE.NVOL) NFV(2,JF2)=NVOL 231 : IF (NFV(1,JF3).EQ.0) NFV(1,JF3)=NVOL 232 : IF (NFV(1,JF3).NE.NVOL) NFV(2,JF3)=NVOL 233 : IF (NFV(1,JF4).EQ.0) NFV(1,JF4)=NVOL 234 : IF (NFV(1,JF4).NE.NVOL) NFV(2,JF4)=NVOL 235 : IVOL(9,NVOL)=35 236 : C 237 : DO 140 I=1,4 238 : IVOL(I,NVOL)=NFC(I,IF1) 239 : 140 CONTINUE 240 : IVOL(5,NVOL)=IP 241 : *C 242 : if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,5) 243 : 1100 FORMAT(' COM433-1 facettes ',i5,' PYR5 ',5i5) 244 : *C 245 : * DO 150 J=1,NPTMAX 246 : * WRITE(6,1110)J,(NPF(I,J),I=1,40) 247 : 1110 FORMAT(I4,4X,40I3) 248 : *150 CONTINUE 249 : C PV INC 250 : C 251 : 131 continue 252 : if (nvol.eq.nvini) then 253 : nptmax=nptini 254 : return 255 : endif 256 : nfcini=nfcmax 257 : C 2EME VOLUME : IF2+IP 258 : C -------------------- 259 : IP1=ISUCC(IF2,II) 260 : IP2=ISUCC(IF2,IP1) 261 : C 262 : * recherche existence de la face 263 : kf1=IFACE3(ip,ii,ip1) 264 : * IF (kf1.ne.0) write (6,*) ' com433 facette assimilee' 265 : IF (kf1.eq.0) THEN 266 : nfcmax=nfcmax+1 267 : kf1=nfcmax 268 : NFC(1,kf1)=ip 269 : NFC(2,kf1)=ii 270 : NFC(3,kf1)=ip1 271 : NFC(4,kf1)=0 272 : elseif (NFC(4,kf1).ne.0.or.ipred(kf1,ip).ne.ii) then 273 : kf1=0 274 : endif 275 : * write (6,*) ' com433 kf1 passe ',kf1 276 : C 277 : * recherche existence de la face 278 : kf2=IFACE3(ip,ip1,ip2) 279 : * IF (kf2.ne.0) write (6,*) ' com433 facette assimilee' 280 : IF (kf2.eq.0) THEN 281 : nfcmax=nfcmax+1 282 : kf2=nfcmax 283 : NFC(1,kf2)=ip 284 : NFC(2,kf2)=ip1 285 : NFC(3,kf2)=ip2 286 : NFC(4,kf2)=0 287 : elseif (NFC(4,kf2).ne.0.or.ipred(kf2,ip).ne.ip1) then 288 : kf2=0 289 : endif 290 : * write (6,*) ' com433 kf2 passe ',kf2 291 : C 292 : * recherche existence de la face 293 : kf3=IFACE3(ip,ip2,ii) 294 : * IF (kf3.ne.0) write (6,*) ' com433 facette assimilee' 295 : IF (kf3.eq.0) THEN 296 : nfcmax=nfcmax+1 297 : kf3=nfcmax 298 : NFC(1,kf3)=ip 299 : NFC(2,kf3)=ip2 300 : NFC(3,kf3)=ii 301 : NFC(4,kf3)=0 302 : elseif (NFC(4,kf3).ne.0.or.ipred(kf3,ip).ne.ip2) then 303 : kf3=0 304 : endif 305 : * write (6,*) ' com433 kf3 passe ',kf3 306 : C 307 : if (diago(ip,ii,diacrd)) then 308 : kf3=0 309 : kf1=0 310 : endif 311 : if (diago(ip,ip1,diacrd)) then 312 : kf1=0 313 : kf2=0 314 : endif 315 : if (diago(ip,ip2,diacrd)) then 316 : kf2=0 317 : kf3=0 318 : endif 319 : if (kf1*kf2*kf3.eq.0) then 320 : * write (6,*) 'com433 impossibilite ' 321 : nfcmax=nfcini 322 : kf1=0 323 : kf2=0 324 : kf3=0 325 : goto 161 326 : endif 326 : CALL REPSUB(IF2) 326 : CALL REPSUB(KF1) 326 : CALL REPSUB(KF2) 326 : CALL REPSUB(KF3) 327 : C 328 : C LE VOLUME CREE EST-IL VALIDE ? 329 : C ------------------------------ 330 : if (.not.SOLTET(IF2,KF1,KF2,KF3,ipin)) goto 160 331 : IF (.NOT.FACET(kF1)) GOTO 160 332 : IF (.NOT.FACET(kF2)) GOTO 160 333 : IF (.NOT.FACET(kF3)) GOTO 160 334 : GOTO 170 335 : C 336 : 160 CONTINUE 337 : C 338 : * write (6,*) ' soltet 2 invalide' 339 : NFCMAX=NFCini 339 : CALL REPSUB(KF3) 339 : CALL REPSUB(KF2) 339 : CALL REPSUB(KF1) 339 : CALL REPSUB(IF2) 340 : kf1=0 341 : kf2=0 342 : kf3=0 343 : goto 161 344 : C 345 : 170 CONTINUE 346 : C 347 : C MEMORISATION DU VOLUME IF2, LF1, KF2, KF3 ET LF4 348 : C ------------------------------------------------ 349 : ICTV=ICTV+1 350 : NVOL=NVOL+1 351 : IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL 352 : IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL 353 : IF (NFV(1,kF1).EQ.0) NFV(1,kF1)=NVOL 354 : IF (NFV(1,kF1).NE.NVOL) NFV(2,kF1)=NVOL 355 : IF (NFV(1,kF2).EQ.0) NFV(1,kF2)=NVOL 356 : IF (NFV(1,kF2).NE.NVOL) NFV(2,kF2)=NVOL 357 : IF (NFV(1,kF3).EQ.0) NFV(1,kF3)=NVOL 358 : IF (NFV(1,kF3).NE.NVOL) NFV(2,kF3)=NVOL 359 : IVOL(9,NVOL)=25 360 : C 361 : DO 180 I=1,3 362 : IVOL(I,NVOL)=NFC(I,IF2) 363 : 180 CONTINUE 364 : IVOL(4,NVOL)=IP 365 : if (iimpi.eq.1) write (6,1180) nfacet,(ivol(i,nvol),i=1,4) 366 : 1180 FORMAT(' COM433-2 facettes ',i5,' TET4 ',4i5) 367 : *C 368 : * DO 190 J=1,NPTMAX 369 : * WRITE(6,1190)J,(NPF(I,J),I=1,40) 370 : 1190 FORMAT(I4,4X,40I3) 371 : *190 CONTINUE 372 : C 373 : 161 continue 374 : nfcini=nfcmax 375 : C 376 : C 3EME VOLUME : IF3+IP 377 : C -------------------- 378 : IP1=ISUCC(IF3,II) 379 : IP2=ISUCC(IF3,IP1) 380 : C ON RETOMBE SUR JF4 (si on ne l'a pas detruit) 381 : C 382 : lf1=IFACE3(ip,ii,ip1) 383 : * IF (lf1.ne.0) write (6,*) ' com433 facette deja existante' 384 : IF (lf1.eq.0) THEN 385 : nfcmax=nfcmax+1 386 : lf1=nfcmax 387 : NFC(1,lf1)=ip 388 : NFC(2,lf1)=ii 389 : NFC(3,lf1)=ip1 390 : NFC(4,lf1)=0 391 : elseif (NFC(4,lf1).ne.0.or.ipred(lf1,ip).ne.ii) then 392 : lf1=0 393 : endif 394 : * write (6,*) ' com433 lf1 passe ',lf1 395 : C 396 : C 397 : * recherche existence de la face 398 : lf2=IFACE3(ip,ip1,ip2) 399 : * IF (lf2.ne.0) write (6,*) ' com433 facette assimilee' 400 : IF (lf2.eq.0) THEN 401 : nfcmax=nfcmax+1 402 : lf2=nfcmax 403 : NFC(1,lf2)=ip 404 : NFC(2,lf2)=ip1 405 : NFC(3,lf2)=ip2 406 : NFC(4,lf2)=0 407 : elseif (NFC(4,lf2).ne.0.or.ipred(lf2,ip).ne.ip1) then 408 : lf2=0 409 : endif 410 : * write (6,*) ' com433 lf2 passe ',lf2 411 : C 412 : C ON RETOMBE SUR KF1 (si on ne l'a pas detruit) 413 : C 414 : lf3=IFACE3(ip,ip2,ii) 415 : * IF (lf3.ne.0) write (6,*) ' com433 facette deja existante' 416 : IF (lf3.eq.0) THEN 417 : nfcmax=nfcmax+1 418 : lf3=nfcmax 419 : NFC(1,lf3)=ip 420 : NFC(2,lf3)=ip2 421 : NFC(3,lf3)=ii 422 : NFC(4,lf3)=0 423 : elseif (NFC(4,lf3).ne.0.or.ipred(lf3,ip).ne.ip2) then 424 : lf3=0 425 : endif 426 : * write (6,*) ' com433 lf3 passe ',lf3 427 : C 428 : if (diago(ip,ii,diacrd)) then 429 : lf3=0 430 : lf1=0 431 : endif 432 : if (diago(ip,ip1,diacrd)) then 433 : lf1=0 434 : lf2=0 435 : endif 436 : if (diago(ip,ip2,diacrd)) then 437 : lf2=0 438 : lf3=0 439 : endif 440 : if (lf1*lf2*lf3.eq.0) then 441 : * write (6,*) 'com433 impossibilite ' 442 : NFCMAX=NFCini 443 : goto 201 444 : endif 445 : C 446 : C 446 : CALL REPSUB(IF3) 446 : CALL REPSUB(LF1) 446 : CALL REPSUB(LF2) 446 : CALL REPSUB(LF3) 447 : C 448 : C LE VOLUME CREE EST-IL VALIDE ? 449 : C ------------------------------ 450 : IF (.NOT.SOLTET(IF3,LF1,LF2,LF3,ipin)) goto 200 451 : IF (.NOT.FACET(LF1)) GOTO 200 452 : IF (.NOT.FACET(LF2)) GOTO 200 453 : IF (.NOT.FACET(LF3)) GOTO 200 454 : GOTO 210 455 : C 456 : 200 CONTINUE 457 : * write (6,*) ' soltet 3 invalide' 458 : C 459 : NFCMAX=NFCini 459 : CALL REPSUB(LF3) 459 : CALL REPSUB(LF2) 459 : CALL REPSUB(LF1) 459 : CALL REPSUB(IF3) 460 : goto 201 461 : C 462 : 210 CONTINUE 463 : C 464 : C MEMORISATION DU VOLUME IF3, JF2, KF1, LF1 ET LF2 465 : C ------------------------------------------------ 466 : ICTV=ICTV+1 467 : NVOL=NVOL+1 468 : IF (NFV(1,IF3).EQ.0) NFV(1,IF2)=NVOL 469 : IF (NFV(1,IF3).NE.NVOL) NFV(2,IF2)=NVOL 470 : IF (NFV(1,lF1).EQ.0) NFV(1,lF1)=NVOL 471 : IF (NFV(1,lF1).NE.NVOL) NFV(2,lF1)=NVOL 472 : IF (NFV(1,lF2).EQ.0) NFV(1,lF2)=NVOL 473 : IF (NFV(1,lF2).NE.NVOL) NFV(2,lF2)=NVOL 474 : IF (NFV(1,lF3).EQ.0) NFV(1,lF3)=NVOL 475 : IF (NFV(1,lF3).NE.NVOL) NFV(2,lF3)=NVOL 476 : IVOL(9,NVOL)=25 477 : C 478 : DO 220 I=1,3 479 : IVOL(I,NVOL)=NFC(I,IF3) 480 : 220 CONTINUE 481 : IVOL(4,NVOL)=IP 482 : if (iimpi.eq.1) write (6,1240) nfacet,(ivol(i,nvol),i=1,4) 483 : 1240 FORMAT(' COM433-3 facettes ',i5,' TET4 ',4i5) 484 : C 485 : * DO 230 J=1,NPTMAX 486 : * WRITE(6,1250)J,(NPF(I,J),I=1,40) 487 : 1250 FORMAT(I4,4X,40I3) 488 : *230 CONTINUE 489 : C 490 : 201 continue 491 : if (nvol.eq.nvini) then 492 : nptmax=nptini 493 : return 494 : endif 495 : C 496 : * if (iimpi.ne.0) write (6,*) ' comm433 point ',nptmax 497 : IGAGNE=1 498 : RETURN 499 : C 500 : C FIN DE LA SUBROUTINE COM433 501 : END 502 : 503 : 504 :
© Cast3M 2003 - All rights reserved.
Disclaimer