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