C TETRA2    SOURCE    PASCAL    22/08/03    21:15:01     11420          
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 PPARAM
-INC CCOPTIO
       LOGICAL REPONS,FACET,SOLTET,DIAGO,IN2,VERDIV,IN
C
       if (iptt.gt.nptmax) then
        IF (IVERB.EQ.1) write (6,*) ' tetra2 iptt nptmax ',iptt,nptmax
       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,ii).ne.jj) 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