1 : C PYRA1 SOURCE FANDEUR 13/01/29 21:16:20 7683 2 : C---------------------------------------------------------------------| 3 : C | 4 : SUBROUTINE PYRA1(II,JJ,IF1,IF2,IGAGNE,IBOUT) 5 : C | 6 : C CETTE SUBROUTINE TENTE DE CREER UNE PYRAMIDE A PARTIR | 7 : C DU TRIANGLE IF1 ET DU QUADRANGLE 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,SOLPYR,SOLTET,DIAGO,IN2,VERDIV,IN 18 : C 19 : * WRITE(6,1000) 20 : 1000 FORMAT(' ----->>> PYRA1 <<<-----') 21 : C 22 : * on se refuse a mailler une pyramide trop ouverte 23 : * if (TETA(IF1,IF2,II,JJ).lt.-100) goto 155 24 : nptini=nptmax 25 : nfcini=nfcmax 26 : ICTF=0 27 : ICTV=0 28 : N3=0 29 : N4=0 30 : N5=0 31 : ipin = 0 32 : * write (6,*) 'entree dans pyra1 ii jj if1 if2 ',ii,jj,if1,if2 33 : * write (6,*) ' liste des facettes ' 34 : * DO 443 I=1,NFCMAX 35 : * IF (IFAT(I).EQ.1) GOTO 443 36 : * WRITE (6,*) I,NFC(1,I),NFC(2,I),NFC(3,I),NFC(4,I) 37 : *443 CONTINUE 38 : C 39 : C RECHERCHE D'UNE 3EME FACETTE IF3 40 : C -------------------------------- 41 : IP1=IPRED(IF1,II) 42 : JP1=ISUCC(IF2,II) 43 : JP2=IPRED(IF2,JJ) 44 : * 45 : if (TETA(IF1,IF2,II,JJ).lt.-100) goto 250 46 : C 47 : IF3=IFACE3(IP1,II,JP1) 48 : C 49 : IF (IF3.NE.0) THEN 50 : * si if3 dans le mauvais sens rien a faire 51 : if (isucc(if3,ii).ne.ip1) then 52 : write (6,*) ' pyra1 face a l''envers if3 ' 53 : return 54 : endif 55 : IF (NFC(4,IF3).NE.0) THEN 55 : CALL prism1(ii,jp1,IF2,IF3,IGAGNE) 56 : RETURN 57 : ENDIF 58 : * WRITE(6,1010)IF3 59 : 1010 FORMAT(' ** IF3=',I4) 60 : N3=IF3 61 : ENDIF 62 : C 63 : C 64 : C RECHERCHE D'UNE 4EME FACETTE IF4 65 : C -------------------------------- 66 : C 67 : IF4=IFACE3(JJ,IP1,JP2) 68 : C 69 : IF (IF4.NE.0) THEN 70 : * si if4 dans le mauvais sens rien a faire 71 : if (isucc(if4,jj).ne.jp2) then 72 : write (6,*) ' pyra1 face a l''envers if4 ' 73 : return 74 : endif 75 : IF (NFC(4,IF4).NE.0) THEN 75 : CALL prism1(jp2,jj,IF2,IF4,IGAGNE) 76 : RETURN 77 : ENDIF 78 : * WRITE(6,1020)IF4 79 : 1020 FORMAT(' ** IF4=',I4) 80 : N4=IF4 81 : ENDIF 82 : C 83 : C 84 : C RECHERCHE D'UNE 5EME FACETTE IF5 85 : C -------------------------------- 86 : C 87 : IF5=IFACE3(JP1,JP2,IP1) 88 : C 89 : IF (IF5.NE.0) THEN 90 : * si if5 dans le mauvais sens rien a faire 91 : if (isucc(if5,jp2).ne.jp1) then 92 : write (6,*) ' pyra1 face a l''envers if5 ' 93 : return 94 : endif 95 : IF (NFC(4,IF5).NE.0) GOTO 9000 96 : * WRITE(6,1030)IF5 97 : 1030 FORMAT(' ** IF5=',I4) 98 : N5=1 99 : ENDIF 100 : C 101 : * TEST LONGUEUR IP1 JP1 ET IP1 JP2 102 : IF (N3.EQ.0.AND.N5.EQ.0) THEN 103 : DNORM=(XYZ(1,IP1)-XYZ(1,JP1))**2 104 : # +(XYZ(2,IP1)-XYZ(2,JP1))**2 105 : # +(XYZ(3,IP1)-XYZ(3,JP1))**2 106 : DTEST= tetrl*XYZ(4,IP1)*XYZ(4,JP1) 107 : IF (DNORM.GT.DTEST) GOTO 250 108 : ENDIF 109 : IF (N4.EQ.0.AND.N5.EQ.0) THEN 110 : DNORM=(XYZ(1,IP1)-XYZ(1,JP2))**2 111 : # +(XYZ(2,IP1)-XYZ(2,JP2))**2 112 : # +(XYZ(3,IP1)-XYZ(3,JP2))**2 113 : DTEST= tetrl*XYZ(4,IP1)*XYZ(4,JP2) 114 : IF (DNORM.GT.DTEST) GOTO 260 115 : ENDIF 116 : IF (IF3.EQ.0.AND.IF5.EQ.0) THEN 117 : IF (DIAGO(IP1,JP1,diacri)) GOTO 9000 118 : ENDIF 119 : IF (IF4.EQ.0.AND.IF5.EQ.0) THEN 120 : IF (DIAGO(IP1,JP2,diacri)) GOTO 9000 121 : ENDIF 122 : C 123 : IF (IF3.EQ.0) THEN 124 : C 125 : C CREATION DE LA FACETTE IF3 126 : C -------------------------- 127 : NFCMAX=NFCMAX+1 128 : IF3=NFCMAX 129 : ICTF=ICTF+1 130 : C 131 : NFC(1,IF3)=II 132 : NFC(2,IF3)=JP1 133 : NFC(3,IF3)=IP1 134 : NFC(4,IF3)=0 135 : C 136 : ENDIF 137 : C 138 : IF (IF4.EQ.0) THEN 139 : C 140 : C CREATION DE LA FACETTE IF4 141 : C -------------------------- 142 : NFCMAX=NFCMAX+1 143 : IF4=NFCMAX 144 : ICTF=ICTF+1 145 : C 146 : NFC(1,IF4)=JJ 147 : NFC(2,IF4)=IP1 148 : NFC(3,IF4)=JP2 149 : NFC(4,IF4)=0 150 : C 151 : ENDIF 152 : C 153 : IF (IF5.EQ.0) THEN 154 : C 155 : C CREATION DE LA FACETTE IF5 156 : C -------------------------- 157 : NFCMAX=NFCMAX+1 158 : IF5=NFCMAX 159 : ICTF=ICTF+1 160 : C 161 : NFC(1,IF5)=JP1 162 : NFC(2,IF5)=JP2 163 : NFC(3,IF5)=IP1 164 : NFC(4,IF5)=0 165 : C 166 : ENDIF 167 : C 168 : C 169 : C ON METS A JOUR LES FACETTES 170 : C --------------------------- 170 : CALL REPSUB(IF1) 170 : CALL REPSUB(IF2) 170 : CALL REPSUB(IF3) 170 : CALL REPSUB(IF4) 170 : CALL REPSUB(IF5) 171 : C 172 : C LE VOLUME CREE EST-IL VALIDE ? 173 : C ------------------------------ 174 : IF (N3.EQ.0) THEN 175 : IF (.NOT.FACET(IF3)) GOTO 190 176 : ENDIF 177 : IF (N4.EQ.0) THEN 178 : IF (.NOT.FACET(IF4)) GOTO 190 179 : ENDIF 180 : IF (N5.EQ.0) THEN 181 : IF (.NOT.FACET(IF5)) GOTO 190 182 : ENDIF 183 : IF (.NOT.SOLPYR(IF2,IF1,IF3,IF4,IF5)) GOTO 190 184 : * test des points milieux 185 : if (n3.eq.0.and.n5.eq.0) then 186 : DO 242 I=1,4 187 : XYZ(I,NPTMAX+1)=(XYZ(4,JP1)*XYZ(I,IP1)+XYZ(4,IP1)*XYZ(I,JP1))/ 188 : # (XYZ(4,JP1)+XYZ(4,IP1)) 189 : 242 CONTINUE 190 : XYZ(4,NPTMAX+1)=SQRT(XYZ(4,IP1)*XYZ(4,JP1)) 190 : CALL DIST(nptmax+1,nptaux,GL,IOK,II,JJ,IP1,JP1,JP2,0,0,0,0,0) 191 : IF (IOK.EQ.0) then 192 : write (6,*) ' pyra1 DIST-1 echoue' 193 : goto 190 194 : endif 195 : IF (gl.lt.xyz(4,nptmax+1)/4) then 196 : write (6,*) ' pyra1 DIST-1-GL echoue' 197 : goto 190 198 : endif 199 : endif 200 : if (n4.eq.0.and.n5.eq.0) then 201 : DO 243 I=1,4 202 : XYZ(I,NPTMAX+1)=(XYZ(4,JP2)*XYZ(I,IP1)+XYZ(4,IP1)*XYZ(I,JP2))/ 203 : # (XYZ(4,JP2)+XYZ(4,IP1)) 204 : 243 CONTINUE 205 : XYZ(4,NPTMAX+1)=SQRT(XYZ(4,IP1)*XYZ(4,JP2)) 205 : CALL DIST(nptmax+1,nptaux,GL,IOK,II,JJ,IP1,JP1,JP2,0,0,0,0,0) 206 : IF (IOK.EQ.0) then 207 : write (6,*) ' pyra1 DIST-2 echoue' 208 : goto 190 209 : endif 210 : IF (gl.lt.xyz(4,nptmax+1)/4) then 211 : write (6,*) ' pyra1 DIST-2-GL echoue' 212 : goto 190 213 : endif 214 : endif 215 : * 216 : C 217 : C LE VOLUME CREE EST VALIDE 218 : C ------------------------- 219 : C MEMORISATION DU VOLUME OBTENU 220 : C ----------------------------- 221 : NVOL=NVOL+1 222 : IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL 223 : IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL 224 : IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL 225 : IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL 226 : IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL 227 : IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL 228 : IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL 229 : IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL 230 : IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL 231 : IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL 232 : IVOL(9,NVOL)=35 233 : DO 170 I=1,4 234 : IVOL(I,NVOL)=NFC(I,IF2) 235 : 170 CONTINUE 236 : IVOL(5,NVOL)=IP1 237 : C 238 : * WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9) 239 : *1100 FORMAT(I3,4X,14I4) 240 : if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,5) 241 : 1100 FORMAT(' PYRA1 facettes ',i5,' pyr5 ',5i5) 242 : C 243 : * DO 180 J=1,NPTMAX 244 : * WRITE(6,1110)J,(NPF(I,J),I=1,40) 245 : *1110 FORMAT(I4,4X,40I3) 246 : *180 CONTINUE 247 : C 248 : C 249 : IGAGNE=1 250 : C 251 : RETURN 252 : C 253 : 190 CONTINUE 254 : C 255 : C LE VOLUME CREE EST INVALIDE: IL FAUT DONC DETRUIRE LES FACETTES 256 : C CREES. -------------------------------------------------------- 256 : CALL REPSUB(IF1) 256 : CALL REPSUB(IF2) 256 : CALL REPSUB(IF3) 256 : CALL REPSUB(IF4) 256 : CALL REPSUB(IF5) 257 : C 258 : NFCMAX=NFCMAX-ICTF 259 : C 260 : GOTO 9000 261 : C 262 : 9000 CONTINUE 263 : IF (IBOUT.EQ.1) RETURN 263 : IF (N3.NE.0) CALL COMBL3(II,IF1,IF2,N3,IGAGNE) 264 : IF (IGAGNE.EQ.1) RETURN 264 : IF (N4.NE.0) CALL COMBL3(JJ,IF2,IF1,N4,IGAGNE) 265 : RETURN 266 : 250 CONTINUE 267 : 260 CONTINUE 268 : * CREATION POINT MILIEU 269 : NPTMAX=NPTMAX+1 270 : XYZ(4,NPTMAX)=(XYZ(4,IP1)+XYZ(4,JP1)+XYZ(4,JP2))/3. 271 : * deplacement du point pour l'eloigner de ii jj 272 : xn1=(xyz(2,jj)-xyz(2,ii))*(xyz(3,ip1)-xyz(3,ii))- 273 : > (xyz(3,jj)-xyz(3,ii))*(xyz(2,ip1)-xyz(2,ii)) 274 : yn1=(xyz(3,jj)-xyz(3,ii))*(xyz(1,ip1)-xyz(1,ii))- 275 : > (xyz(1,jj)-xyz(1,ii))*(xyz(3,ip1)-xyz(3,ii)) 276 : zn1=(xyz(1,jj)-xyz(1,ii))*(xyz(2,ip1)-xyz(2,ii))- 277 : > (xyz(2,jj)-xyz(2,ii))*(xyz(1,ip1)-xyz(1,ii)) 278 : * scal=xn1*(xyz(1,jp1)-xyz(1,ii))+xn2*(xyz(2,jp1)-xyz(2,ii))+ 279 : * > xn3*(xyz(3,jp1)-xyz(3,ii)) 280 : * write (6,*) ' dnas tetra scal ',scal 281 : * write (6,*) ' ii ',(XYZ(i,ii),i=1,4) 282 : * write (6,*) ' jj ',(XYZ(i,jj),i=1,4) 283 : * write (6,*) ' ip ',(XYZ(i,ip),i=1,4) 284 : * write (6,*) ' jp ',(XYZ(i,jp),i=1,4) 285 : * write (6,*) ' xn ',xn1,yn1,zn1 286 : sn1=sqrt(xn1**2+yn1**2+zn1**2) 287 : xn1=xn1/sn1 288 : yn1=yn1/sn1 289 : zn1=zn1/sn1 290 : xn2=((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(3,jj)-xyz(3,ii))- 291 : > ((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(2,jj)-xyz(2,ii)) 292 : yn2=((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(1,jj)-xyz(1,ii))- 293 : > ((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(3,jj)-xyz(3,ii)) 294 : zn2=((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(2,jj)-xyz(2,ii))- 295 : > ((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(1,jj)-xyz(1,ii)) 296 : sn2=sqrt(xn2**2+yn2**2+zn2**2) 297 : xn2=xn2/sn2 298 : yn2=yn2/sn2 299 : zn2=zn2/sn2 300 : xn=(xn1+xn2)/2 301 : yn=(yn1+yn2)/2 302 : zn=(zn1+zn2)/2 303 : sn=sqrt(xn**2+yn**2+zn**2) 304 : xn=xn/sn 305 : yn=yn/sn 306 : zn=zn/sn 307 : * xmil=(xyz(1,ii)+xyz(1,jj))/2 308 : * ymil=(xyz(2,ii)+xyz(2,jj))/2 309 : * zmil=(xyz(3,ii)+xyz(3,jj))/2 310 : * 311 : xv=xyz(1,jj)-xyz(1,ii) 312 : yv=xyz(2,jj)-xyz(2,ii) 313 : zv=xyz(3,jj)-xyz(3,ii) 314 : sv=sqrt(xv**2+yv**2+zv**2) 315 : xv=xv/sv 316 : yv=yv/sv 317 : zv=zv/sv 318 : xli=xv*(xyz(1,ip1)-xyz(1,ii))+yv*(xyz(2,ip1)-xyz(2,ii))+ 319 : > zv*(xyz(3,ip1)-xyz(3,ii)) 320 : xlj1=xv*(xyz(1,jp1)-xyz(1,ii))+yv*(xyz(2,jp1)-xyz(2,ii))+ 321 : > zv*(xyz(3,jp1)-xyz(3,ii)) 322 : xlj2=xv*(xyz(1,jp2)-xyz(1,ii))+yv*(xyz(2,jp2)-xyz(2,ii))+ 323 : > zv*(xyz(3,jp2)-xyz(3,ii)) 324 : xl=(xli+xlj1+xlj2+2*sv+2*0)/7 325 : xl=0.5*sv 326 : xmil=xyz(1,ii)+xl*xv 327 : ymil=xyz(2,ii)+xl*yv 328 : zmil=xyz(3,ii)+xl*zv 329 : expf = xyz(4,nptmax) 330 : xyz(1,nptmax)=xmil+xn*expf*expfac 331 : xyz(2,nptmax)=ymil+yn*expf*expfac 332 : xyz(3,nptmax)=zmil+zn*expf*expfac 333 : * write (6,*) ' pyra1 creation de 2 elements et pt ',nptmax 334 : * write (6,*) ' coordonnees ',(XYZ(i,nptmax),i=1,4) 335 : * write (6,*) ' coordonnees ',(XYZ(i,ip),i=1,4) 336 : * write (6,*) ' coordonnees ',(XYZ(i,jp),i=1,4) 337 : * write (6,*) ' coordonnees ',xmil,ymil,zmil 338 : * CREATION DES ELEMENTS 339 : IPTT=NPTMAX 339 : CALL DIST(iptt,nptaux,GL,IOK,ii,jj,ip1,jp1,jp2,0,0,0,0,0) 340 : IF (IOK.EQ.0) THEN 341 : NPTMAX=nptini 342 : WRITE (6,*) ' pyra1 DIST ',nptaux 343 : * if (nptaux.eq.0) goto 9000 344 : return 345 : iptt=nptaux 346 : ENDIF 347 : IF (gl.lt.xyz(4,iptt)/4) then 348 : write (6,*) 'pyra1 GL-1' 349 : nptmax=nptini 350 : return 351 : endif 352 : 253 continue 353 : IF (.NOT.IN2(ii,IPTT,nfcini).or..NOT.IN2(jj,IPTT,nfcini)) THEN 354 : NPTMAX=nptini 355 : goto 9000 356 : ENDIF 357 : * recherche existence de la face 358 : IF3=IFACE3(ii,iptt,ip1) 359 : IF (IF3.ne.0) write (6,*) ' pyra1 facette assimilee' 360 : IF (IF3.eq.0) THEN 361 : NFCMAX=NFCMAX+1 362 : IF3=NFCMAX 363 : NFC(1,IF3)=II 364 : NFC(2,IF3)=iptt 365 : NFC(3,IF3)=IP1 366 : NFC(4,IF3)=0 367 : elseif (NFC(4,if3).ne.0.or.ipred(if3,ii).ne.iptt) then 368 : write (6,*) ' pyra1 probleme facette if3 ',if3 369 : nptmax=nptini 370 : nfcmax=nfcini 371 : goto 9000 372 : endif 373 : * recherche existence de la face 374 : IF4=IFACE3(ii,jp1,iptt) 375 : IF (IF4.ne.0) write (6,*) ' pyra1 facette assimilee' 376 : IF (IF4.eq.0) THEN 377 : NFCMAX=NFCMAX+1 378 : IF4=NFCMAX 379 : NFC(1,IF4)=II 380 : NFC(2,IF4)=JP1 381 : NFC(3,IF4)=iptt 382 : NFC(4,IF4)=0 383 : elseif (NFC(4,if4).ne.0.or.ipred(if4,ii).ne.jp1) then 384 : write (6,*) ' pyra1 probleme facette if4 ',if4 385 : nptmax=nptini 386 : nfcmax=nfcini 387 : goto 9000 388 : endif 389 : * recherche existence de la face 390 : IF5=IFACE3(jp1,jp2,iptt) 391 : IF (IF5.ne.0) write (6,*) ' pyra1 facette assimilee' 392 : IF (IF5.eq.0) THEN 393 : NFCMAX=NFCMAX+1 394 : IF5=NFCMAX 395 : NFC(1,IF5)=JP1 396 : NFC(2,IF5)=JP2 397 : NFC(3,IF5)=iptt 398 : NFC(4,IF5)=0 399 : elseif (NFC(4,if5).ne.0.or.ipred(if5,jp1).ne.jp2) then 400 : write (6,*) ' pyra1 probleme facette if5 ',if5 401 : nptmax=nptini 402 : nfcmax=nfcini 403 : goto 9000 404 : endif 405 : * recherche existence de la face 406 : IF6=IFACE3(jp2,jj,iptt) 407 : IF (IF6.ne.0) write (6,*) ' pyra1 facette assimilee' 408 : IF (IF6.eq.0) THEN 409 : NFCMAX=NFCMAX+1 410 : IF6=NFCMAX 411 : NFC(1,IF6)=JP2 412 : NFC(2,IF6)=JJ 413 : NFC(3,IF6)=iptt 414 : NFC(4,IF6)=0 415 : elseif (NFC(4,if6).ne.0.or.ipred(if6,jp2).ne.jj) then 416 : write (6,*) ' pyra1 probleme facette if6 ',if6 417 : nptmax=nptini 418 : nfcmax=nfcini 419 : goto 9000 420 : endif 421 : * recherche existence de la face 422 : IF7=IFACE3(jj,ip1,iptt) 423 : IF (IF7.ne.0) write (6,*) ' pyra1 facette assimilee' 424 : IF (IF7.eq.0) THEN 425 : NFCMAX=NFCMAX+1 426 : IF7=NFCMAX 427 : NFC(1,IF7)=JJ 428 : NFC(2,IF7)=IP1 429 : NFC(3,IF7)=iptt 430 : NFC(4,IF7)=0 431 : elseif (NFC(4,if7).ne.0.or.ipred(if7,jj).ne.ip1) then 432 : write (6,*) ' pyra1 probleme facette if7 ',if7 433 : nptmax=nptini 434 : nfcmax=nfcini 435 : goto 9000 436 : endif 437 : * creation facette commune (necessaire pour faire les verification) 438 : IF8=IFACE3(ii,jj,iptt) 439 : IF (IF8.ne.0) write(6,*)' pyra1 facette if8 existe deja => echec' 440 : IF (IF8.ne.0) THEN 441 : nptmax=nptini 442 : nfcmax=nfcini 443 : goto 9000 444 : endif 445 : NFCMAX=NFCMAX+1 446 : IF8=NFCMAX 447 : NFC(1,IF8)=ii 448 : NFC(2,IF8)=jj 449 : NFC(3,IF8)=iptt 450 : NFC(4,IF8)=0 451 : * si necessaire verification diago 452 : * if (nptini.eq.nptmax) then 453 : IF (DIAGO(iptt,ii,diacri)) GOTO 275 454 : IF (DIAGO(iptt,jj,diacri)) GOTO 275 455 : IF (DIAGO(iptt,ip1,diacri)) GOTO 275 456 : IF (DIAGO(iptt,jp1,diacri)) GOTO 275 457 : IF (DIAGO(iptt,jp2,diacri)) GOTO 275 458 : goto 276 459 : 275 continue 460 : nptmax=nptini 461 : nfcmax=nfcini 462 : goto 9000 463 : 276 continue 464 : * endif 465 : C 465 : CALL REPSUB(IF1) 465 : CALL REPSUB(IF3) 465 : CALL REPSUB(IF7) 465 : CALL REPSUB(IF8) 466 : * verification du premier element element 467 : IF (.NOT.SOLTET(IF1,IF3,IF7,IF8,ipin)) then 468 : write (6,*) 'pyra1 soltet invalide' 469 : GOTO 160 470 : endif 471 : IF (.NOT.FACET(IF3)) then 472 : write(6,*) ' pyra1 facet if3 invalide' 473 : GOTO 160 474 : ENDIF 475 : IF (.NOT.FACET(IF7)) then 476 : write(6,*) ' pyra1 facet if7 invalide' 477 : GOTO 160 478 : ENDIF 478 : CALL REPSUB(IF2) 478 : CALL REPSUB(IF4) 478 : CALL REPSUB(IF5) 478 : CALL REPSUB(IF6) 478 : CALL REPSUB(IF8) 479 : * verification du deuxieme element element 480 : IF (.NOT.SOLPYR(IF2,IF4,IF5,IF6,IF8)) then 481 : write (6,*) 'pyra1 solpyr invalide' 482 : GOTO 165 483 : endif 484 : IF (.NOT.FACET(IF4)) then 485 : write(6,*) ' pyra1 facet if4 invalide' 486 : GOTO 165 487 : ENDIF 488 : IF (.NOT.FACET(IF5)) then 489 : write(6,*) ' pyra1 facet if5 invalide' 490 : GOTO 165 491 : ENDIF 492 : IF (.NOT.FACET(IF6)) then 493 : write(6,*) ' pyra1 facet if6 invalide' 494 : GOTO 165 495 : ENDIF 496 : * OK pour creation elements 497 : NVOL=NVOL+1 498 : IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL 499 : IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL 500 : IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL 501 : IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL 502 : IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL 503 : IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL 504 : IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL 505 : IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL 506 : IVOL(9,NVOL)=35 507 : DO 280 I=1,4 508 : IVOL(I,NVOL)=NFC(I,IF2) 509 : 280 CONTINUE 510 : IVOL(5,NVOL)=iptt 511 : if (iimpi.eq.1) write (6,1102) nfacet,(ivol(i,nvol),i=1,5) 512 : 1102 FORMAT(' PYRA1-1 facettes ',i5,' pyr5 ',8i5) 513 : NVOL=NVOL+1 514 : IVOL(9,NVOL)=25 515 : IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL 516 : IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL 517 : IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL 518 : IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL 519 : IF (NFV(1,IF7).EQ.0) NFV(1,IF7)=NVOL 520 : IF (NFV(1,IF7).NE.NVOL) NFV(2,IF7)=NVOL 521 : DO 282 I=1,3 522 : IVOL(I,NVOL)=NFC(I,IF1) 523 : 282 CONTINUE 524 : IVOL(4,NVOL)=iptt 525 : if (iimpi.eq.1) write (6,1101) nfacet,(ivol(i,nvol),i=1,4) 526 : 1101 FORMAT(' PYRA1-2 facettes ',i5,' tet4 ',8i5) 527 : * write (6,*) ' pyra1 2 elements fabriques ' 528 : * write (6,*) ' liste des facettes ' 529 : * DO 444 I=1,NFCMAX 530 : * IF (IFAT(I).EQ.1) GOTO 444 531 : * WRITE (6,*) I,NFC(1,I),NFC(2,I),NFC(3,I),NFC(4,I) 532 : *444 CONTINUE 533 : IGAGNE=1 534 : RETURN 535 : 165 continue 535 : CALL REPSUB(IF8) 535 : CALL REPSUB(IF6) 535 : CALL REPSUB(IF5) 535 : CALL REPSUB(IF4) 535 : CALL REPSUB(IF2) 536 : 160 continue 536 : CALL REPSUB(IF8) 536 : CALL REPSUB(IF7) 536 : CALL REPSUB(IF3) 536 : CALL REPSUB(IF1) 537 : nptmax=nptini 538 : nfcmax=nfcini 539 : goto 9000 540 : 541 : END 542 : 543 : 544 :
© Cast3M 2003 - All rights reserved.
Disclaimer