C TETRA2 SOURCE FANDEUR 13/01/29 21:16:33 7683 C---------------------------------------------------------------------| C | SUBROUTINE TETRA2(II,JJ,IF1,IF2,IGAGNE,IPTT) C | C CETTE SUBROUTINE TENTE DE CREER DEUX TETRAEDRES A PARTIR | C DES 2 TRIANGLES IF1 ET IF2. | C | C - IGAGNE=1 EN CAS DE SUCCES | C - IGAGNE=0 EN CAS D'ECHEC | C | C---------------------------------------------------------------------| C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC TDEMAIT -INC CCOPTIO LOGICAL REPONS,FACET,SOLTET,DIAGO,IN2,VERDIV,IN C if (iptt.gt.nptmax) then write (6,*) ' tetra2 iptt nptmax ',iptt,nptmax stop 16 endif nfcini=nfcmax ip1=0 ip2=0 N3=0 N4=0 N5=0 N6=0 N7=0 ICTF=0 ICTV=0 ipas=0 ipin = 0 C * IF (.NOT.IN2(ii,IPTT,nfcini).or..NOT.IN2(jj,IPTT,nfcini)) THEN * write (6,*) ' tetra2 test in2 echoue ',ii,jj,iptt * RETURN * ENDIF IP=IPRED(IF1,II) JP=ISUCC(IF2,II) * CREATION FACETTE PREMIER ELEMENT * recherche existence de la face IF3=IFACE3(ii,iptt,ip) * IF (IF3.ne.0) write (6,*) ' tetra2 if3 assimilee ',ii,iptt,ip IF (IF3.eq.0) THEN nfcmax=nfcmax+1 if3=nfcmax NFC(1,IF3)=ii NFC(2,IF3)=iptt NFC(3,IF3)=ip NFC(4,IF3)=0 N3=IF3 elseif (NFC(4,if3).ne.0.or.ipred(if3,ii).ne.iptt) then * write (6,*) ' tetra2 probleme facette if3 ',if3 nfcmax=nfcini return endif * recherche existence de la face IF4=IFACE3(jj,ip,iptt) * IF (IF4.ne.0) write (6,*) ' tetra2 if4 assimilee',jj,ip,iptt IF (IF4.eq.0) THEN NFCMAX=NFCMAX+1 IF4=NFCMAX NFC(1,IF4)=jj NFC(2,IF4)=ip NFC(3,IF4)=iptt NFC(4,IF4)=0 N4=IF4 elseif (NFC(4,if4).ne.0.or.ipred(if4,jj).ne.ip) then * write (6,*) ' tetra2 probleme facette if4 ',if4 nfcmax=nfcini return endif * creation facette commune (necessaire pour faire les verification) IF7=IFACE3(ii,jj,iptt) * IF (IF7.ne.0) write(6,*)'tetra2 facette if7 existe deja => echec' * IF (IF7.ne.0) THEN * nfcmax=nfcini * return * endif * IF (IF7.ne.0) write (6,*) ' tetra2 if7 assimilee',jj,ip,iptt IF (IF7.eq.0) THEN NFCMAX=NFCMAX+1 IF7=NFCMAX NFC(1,IF7)=ii NFC(2,IF7)=jj NFC(3,IF7)=iptt NFC(4,IF7)=0 N7=IF7 elseif (NFC(4,if7).ne.0.or.ipred(if7,jj).ne.ii) then * write (6,*) ' tetra2 probleme facette if7 ',if7 nfcmax=nfcini return endif * nfcmoi=nfcmax si on veut garder le 2eme element nfcmoi=nfcini * CREATION FACETTES 2eme element * recherche existence de la face IF5=IFACE3(ii,jp,iptt) * IF (IF5.ne.0) write (6,*) ' tetra2 if5 assimilee',ii,jp,iptt IF (IF5.eq.0) THEN NFCMAX=NFCMAX+1 IF5=NFCMAX NFC(1,IF5)=ii NFC(2,IF5)=JP NFC(3,IF5)=iptt NFC(4,IF5)=0 N5=IF5 elseif (NFC(4,if5).ne.0.or.ipred(if5,ii).ne.jp) then * write (6,*) ' tetra2 probleme facette if5 ',if5 nfcmax=nfcini return endif * recherche existence de la face IF6=IFACE3(jj,iptt,jp) * IF (IF6.ne.0) write (6,*) ' tetra2 if6 assimilee',jj,iptt,jp IF (IF6.eq.0) THEN NFCMAX=NFCMAX+1 IF6=NFCMAX NFC(1,IF6)=jj NFC(2,IF6)=iptt NFC(3,IF6)=jp NFC(4,IF6)=0 N6=IF6 elseif (NFC(4,if6).ne.0.or.ipred(if6,jj).ne.iptt) then * write (6,*) ' tetra2 probleme facette if6 ',if6 nfcmax=nfcini return endif * si necessaire verification diago * on se fait aussi une petite verif de longueur IF (N3.NE.0.AND.N5.NE.0) then IF (DIAGO(iptt,ii,diacrd)) GOTO 274 DNORM=(XYZ(1,IPTT)-XYZ(1,II))**2 # +(XYZ(2,IPTT)-XYZ(2,II))**2 # +(XYZ(3,IPTT)-XYZ(3,II))**2 DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,II) IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 275 ENDIF IF (N4.NE.0.AND.N6.NE.0) then IF (DIAGO(iptt,jj,diacrd)) GOTO 274 DNORM=(XYZ(1,IPTT)-XYZ(1,JJ))**2 # +(XYZ(2,IPTT)-XYZ(2,JJ))**2 # +(XYZ(3,IPTT)-XYZ(3,JJ))**2 DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,JJ) IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 275 ENDIF IF (N3.NE.0.AND.N4.NE.0) then IF (DIAGO(iptt,ip,diacrd)) GOTO 274 DNORM=(XYZ(1,IPTT)-XYZ(1,IP))**2 # +(XYZ(2,IPTT)-XYZ(2,IP))**2 # +(XYZ(3,IPTT)-XYZ(3,IP))**2 DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,IP) IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 275 ENDIF IF (N3.NE.0) THEN * TEST DU POINT MILIEU de if3 DO 242 I=1,4 XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if3))+XYZ(I,nfc(2,if3))+ > XYZ(I,nfc(3,if3)))/3 242 CONTINUE * call vcrit(nptmax+3) * CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0) * IF (IOK.EQ.0) goto 277 ENDIF IF (N4.NE.0) THEN * TEST DU POINT MILIEU de if4 DO 243 I=1,4 XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if4))+XYZ(I,nfc(2,if4))+ > XYZ(I,nfc(3,if4)))/3 243 CONTINUE * call vcrit(nptmax+3) * CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0) * IF (IOK.EQ.0) goto 277 ENDIF IF (N5.NE.0) THEN * TEST DU POINT MILIEU de if7 DO 244 I=1,4 XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if7))+XYZ(I,nfc(2,if7))+ > XYZ(I,nfc(3,if7)))/3 244 CONTINUE * call vcrit(nptmax+3) * CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0) * IF (IOK.EQ.0) goto 277 ENDIF goto 276 274 continue nfcmax=nfcini * write (6,*) ' tetra2 echec diago 1 ',ii,jj,ip,jp,iptt return 275 continue nfcmax=nfcini * write (6,*) ' tetra2 echec longueur 1' return 277 continue nfcmax=nfcini * write (6,*) ' tetra2 dist pt milieu' return 278 continue nfcmax=nfcini * write (6,*) ' tetra2 gl pt milieu' return 276 continue C CALL REPSUB(IF1) CALL REPSUB(IF3) CALL REPSUB(IF4) CALL REPSUB(IF7) * verification du premier element IF (.NOT.SOLTET(IF1,IF3,IF4,IF7,IPIN)) then * write (6,*) 'tetra2 soltet invalide - 1',ii,ip,iptt,jj GOTO 160 ENDIF IF (.NOT.FACET(IF3)) then * write(6,*) ' tetra2 facet if3 invalide' GOTO 160 ENDIF IF (.NOT.FACET(IF4)) then * write(6,*) ' tetra2 facet if4 invalide' GOTO 160 ENDIF IF (.NOT.FACET(IF7)) then * write(6,*) ' tetra2 facet if7 invalide' GOTO 160 ENDIF * IF (N5.NE.0.AND.N6.NE.0) then IF (DIAGO(iptt,jp,diacrd)) GOTO 284 DNORM=(XYZ(1,IPTT)-XYZ(1,JP))**2 # +(XYZ(2,IPTT)-XYZ(2,JP))**2 # +(XYZ(3,IPTT)-XYZ(3,JP))**2 DTEST=tetrl*XYZ(4,IPTT)*XYZ(4,JP) IF (DNORM.GT.DTEST.and.nptmax.ne.iptt) GOTO 285 ENDIF IF (N5.NE.0) THEN * TEST DU POINT MILIEU de if5 DO 245 I=1,4 XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if5))+XYZ(I,nfc(2,if5))+ > XYZ(I,nfc(3,if5)))/3 245 CONTINUE * call vcrit(nptmax+3) * CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0) * IF (IOK.EQ.0) goto 287 ENDIF IF (N6.NE.0) THEN * TEST DU POINT MILIEU de if6 DO 246 I=1,4 XYZ(I,NPTMAX+3)=(XYZ(I,nfc(1,if6))+XYZ(I,nfc(2,if6))+ > XYZ(I,nfc(3,if6)))/3 246 CONTINUE * call vcrit(nptmax+3) * CALL DIST(nptmax+3,nptaux,GL,IOK,II,JJ,IP,JP,iptt,0,0,0,0,0) * IF (IOK.EQ.0) goto 287 ENDIF goto 286 284 continue nfcmax=nfcmoi * write (6,*) ' tetra2 echec diago 2 ',ii,jj,ip,jp,iptt goto 160 285 continue nfcmax=nfcmoi * write (6,*) ' tetra2 echec longueur 2' goto 160 287 continue nfcmax=nfcmoi * write (6,*) ' tetra2 echec dist 2' goto 160 288 continue nfcmax=nfcmoi * write (6,*) ' tetra2 echec gl 2' goto 160 286 continue CALL REPSUB(IF2) CALL REPSUB(IF5) CALL REPSUB(IF6) CALL REPSUB(IF7) * verification du deuxieme element element IF (.NOT.SOLTET(IF2,IF5,IF6,IF7,IPIN)) then * write (6,*) 'tetra2 soltet invalide - 2 ',ii,jp,iptt,jj GOTO 165 endif IF (.NOT.FACET(IF5)) then * write(6,*) ' tetra2 facet if5 invalide' GOTO 165 ENDIF IF (.NOT.FACET(IF6)) then * write(6,*) ' tetra2 facet if6 invalide' GOTO 165 ENDIF * CREATION premier ELEMENT IGAGNE=1 NVOL=NVOL+1 IVOL(9,NVOL)=25 IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL DO 254 I=1,3 IVOL(I,NVOL)=NFC(I,IF1) 254 CONTINUE IVOL(4,NVOL)=IPTT qual=qualt(ii,jj,ip,iptt) if (iimpi.eq.1) write (6,1100) nvol,nfacet,qual, > (ivol(i,nvol),i=1,4) 1100 format (' TETRA2 ',i5,i6,f8.4,4i6) * CREATION deuxieme ELEMENT NVOL=NVOL+1 IVOL(9,NVOL)=25 IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL DO 256 I=1,3 IVOL(I,NVOL)=NFC(I,IF2) 256 CONTINUE IVOL(4,NVOL)=IPTT qual=qualt(jj,ii,jp,iptt) if (iimpi.eq.1) write (6,1100) nvol,nfacet,qual, > (ivol(i,nvol),i=1,4) IGAGNE=1 RETURN 165 continue CALL REPSUB(IF7) CALL REPSUB(IF6) CALL REPSUB(IF5) CALL REPSUB(IF2) nfcmax=nfcmoi * if (nptmax.eq.iptt) * > write (6,*) ' tetra2 echec 2eme element' * return on ne fait aucun element 160 continue CALL REPSUB(IF7) CALL REPSUB(IF4) CALL REPSUB(IF3) CALL REPSUB(IF1) nfcmax=nfcini return RETURN END