C COM443    SOURCE    JC220346  16/11/29    21:15:05     9221           
C---------------------------------------------------------------------|
C                                                                     |
       SUBROUTINE COM443(II,MF1,MF2,MF3,IGAGNE)
C                                                                     |
C      CETTE SUBROUTINE TENTE DE CREER 2 PYRAMIDES ET 1 TETRAEDRE     |
C      A PARTIR DES QUADRANGLES IF1, IF2 ET DU TRIANGLE IF3 EN        |
C      CREANT UN POINT                                                |
C      CENTRAL SUPPLEMENTAIRE                                         |
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,SOLPYR,SOLTET,IN2,diago
      nfcini=nfcmax
      nptini=nptmax
      nvini=nvol
      ICTP=0
      ipin = 0
C
C  METTRE LES FACES DANS L'ORDRE
      IF3=MF3
      IP=ISUCC(IF3,II)
      IF (IP.EQ.IPRED(MF1,II)) IF1=MF1
      IF (IP.EQ.IPRED(MF2,II)) IF1=MF2
      IP=ISUCC(IF1,II)
      IF (IP.EQ.IPRED(MF1,II)) IF2=MF1
      IF (IP.EQ.IPRED(MF2,II)) IF2=MF2
*      WRITE(6,1000)IF1,IF2,IF3
1000   FORMAT(' COM443 IF1=',I5,'  IF2=',I5,'  IF3=',I5)
C
       ICTF=0
       ICTV=0
C
C
C      CREATION DU POINT CENTRAL : IP
C      ------------------------------
       IP1=II
       IP2=ISUCC(IF1,IP1)
       IP3=ISUCC(IF1,IP2)
       IP4=ISUCC(IF1,IP3)
       ICTP=1
       NPTMAX=NPTMAX+1
       IP=NPTMAX
C
       DO 100 I=1,4
*             XYZ(I,IP)=(XYZ(I,IP1)+XYZ(I,IP2)+XYZ(I,IP3)
*    #                  +XYZ(I,IP4))/4.
              XYZ(I,IP)=(XYZ(I,IP2)+XYZ(I,IP4))/2.
100    CONTINUE
       JP1=II
       JP2=ISUCC(IF2,JP1)
       JP3=ISUCC(IF2,JP2)
       JP4=ISUCC(IF2,JP3)
C
       DO 102 I=1,4
*             XYZ(I,IP)=XYZ(I,IP)+
*    #   (XYZ(I,JP1)+XYZ(I,JP2)+XYZ(I,JP3)+XYZ(I,JP4))/4.
              XYZ(I,IP)=XYZ(I,IP)+
     #   (XYZ(I,JP2)+XYZ(I,JP4))/2.
102    CONTINUE
       KP1=II
       KP2=ISUCC(IF3,KP1)
       KP3=ISUCC(IF3,KP2)
C
       DO 104 I=1,4
              XYZ(I,IP)=(XYZ(I,IP)+
     #  (XYZ(I,KP2)+XYZ(I,KP3))/2.)/3.
104    CONTINUE
       DO 103 I=1,3
         XYZ(I,IP)=XYZ(I,II)+expcom*(XYZ(I,IP)-XYZ(I,II))
103    CONTINUE
C
*      WRITE(6,1010)IP,(XYZ(I,IP),I=1,4)
1010   FORMAT(' POINT:',I3,':',4F7.2)
*   verif des volumes
       if ((vol(ip,ii,ip2,ip4).gt.0).or.
     >     (vol(ip,ii,jp2,jp4).gt.0).or.
     >     (vol(ip,ii,kp2,kp3).gt.0)) then
         IF (IVERB.EQ.1) write (6,*) ' com443 volume positif '
         nptmax=nptini
         return
       endif
C
       CALL DIST(IP,JP,GL,IOK,IP1,IP2,IP3,IP4,JP2,JP3,JP4,KP2,KP3,0)
       IF (IOK.EQ.0) THEN
       NPTMAX=NPTini
       RETURN
       ICTP=0
       NPTMAX=NPTMAX-1
       IP=JP
*      WRITE (6,*) ' COM443 POINT ASSIMILE ',JP
       ENDIF
       REPONS=IN2(ii,IP,nfcini)
       IF (REPONS) GOTO 110
       NPTMAX=NPTini
       RETURN
C
110    CONTINUE
C
C      CREATION D'UNE PYRAMIDE : IF1+IP
C      --------------------------------
       IP1=ISUCC(IF1,II)
       IP2=ISUCC(IF1,IP1)
       IP3=ISUCC(IF1,IP2)
*     recherche existence de la face
       jf1=IFACE3(ip,ii,ip1)
*       IF (jf1.ne.0) write (6,*) ' com443 facette assimilee'
       IF (jf1.eq.0) THEN
        nfcmax=nfcmax+1
        jf1=nfcmax
        NFC(1,jf1)=ip
        NFC(2,jf1)=ii
        NFC(3,jf1)=ip1
        NFC(4,jf1)=0
       elseif (NFC(4,jf1).ne.0.or.ipred(jf1,ip).ne.ii) then
        jf1=0
       endif
*       write (6,*) ' com443 jf1 passe ',jf1
C
*     recherche existence de la face
       jf2=IFACE3(ip,ip1,ip2)
*       IF (jf2.ne.0) write (6,*) ' com443 facette assimilee'
       IF (jf2.eq.0) THEN
        nfcmax=nfcmax+1
        jf2=nfcmax
        NFC(1,jf2)=ip
        NFC(2,jf2)=ip1
        NFC(3,jf2)=ip2
        NFC(4,jf2)=0
       elseif (NFC(4,jf2).ne.0.or.ipred(jf2,ip).ne.ip1) then
        jf2=0
       endif
*       write (6,*) ' com443 jf2 passe ',jf2
C
*     recherche existence de la face
       jf3=IFACE3(ip,ip2,ip3)
*       IF (jf3.ne.0) write (6,*) ' com443 facette assimilee'
       IF (jf3.eq.0) THEN
        nfcmax=nfcmax+1
        jf3=nfcmax
        NFC(1,jf3)=ip
        NFC(2,jf3)=ip2
        NFC(3,jf3)=ip3
        NFC(4,jf3)=0
       elseif (NFC(4,jf3).ne.0.or.ipred(jf3,ip).ne.ip2) then
        jf3=0
       endif
*       write (6,*) ' com443 jf3 passe ',jf3
C
*     recherche existence de la face
       jf4=IFACE3(ip,ip3,ii)
*       IF (jf4.ne.0) write (6,*) ' com443 facette assimilee'
       IF (jf4.eq.0) THEN
        nfcmax=nfcmax+1
        jf4=nfcmax
        NFC(1,jf4)=ip
        NFC(2,jf4)=ip3
        NFC(3,jf4)=ii
        NFC(4,jf4)=0
       elseif (NFC(4,jf4).ne.0.or.ipred(jf4,ip).ne.ip3) then
        jf4=0
       endif
*       write (6,*) ' com443 jf4 passe ',jf4
C
       if (diago(ip,ii,diacrd)) then
        jf4=0
        jf1=0
       endif
       if (diago(ip,ip1,diacrd)) then
        jf1=0
        jf2=0
       endif
       if (diago(ip,ip2,diacrd)) then
        jf2=0
        jf3=0
       endif
       if (diago(ip,ip3,diacrd)) then
        jf3=0
        jf4=0
       endif
       if (jf1*jf2*jf3*jf4.eq.0) then
*        write (6,*) 'com443 impossibilite '
        nfcmax=nfcini
        jf1=0
        jf2=0
        jf3=0
        jf4=0
        goto 131
       endif
       CALL REPSUB(IF1)
       CALL REPSUB(JF1)
       CALL REPSUB(JF2)
       CALL REPSUB(JF3)
       CALL REPSUB(JF4)
C
C      LE VOLUME CREE EST-IL VALIDE ?
C      ------------------------------
       IF (.not.SOLPYR(IF1,JF1,JF2,JF3,JF4)) GOTO 129
       IF (.NOT.FACET(jF1)) GOTO 129
       IF (.NOT.FACET(jF2)) GOTO 129
       IF (.NOT.FACET(jF3)) GOTO 129
       IF (.NOT.FACET(jF4)) GOTO 129
       goto 130
C
C      LE VOLUME EST INVALIDE
C      ----------------------
 129   continue
*      write (6,*) ' solpyr 1 invalide'
       NFCMAX=NFCini
       CALL REPSUB(JF4)
       CALL REPSUB(JF3)
       CALL REPSUB(JF2)
       CALL REPSUB(JF1)
       CALL REPSUB(IF1)
        jf1=0
        jf2=0
        jf3=0
        jf4=0
       goto 131
C
130    CONTINUE
C
C      MEMORISATION DU VOLUME OBTENU : IF1, JF1, JF2, JF3 ET JF4
C      ---------------------------------------------------------
       ICTV=ICTV+1
       NVOL=NVOL+1
       IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
       IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
       IF (NFV(1,JF1).EQ.0) NFV(1,JF1)=NVOL
       IF (NFV(1,JF1).NE.NVOL) NFV(2,JF1)=NVOL
       IF (NFV(1,JF2).EQ.0) NFV(1,JF2)=NVOL
       IF (NFV(1,JF2).NE.NVOL) NFV(2,JF2)=NVOL
       IF (NFV(1,JF3).EQ.0) NFV(1,JF3)=NVOL
       IF (NFV(1,JF3).NE.NVOL) NFV(2,JF3)=NVOL
       IF (NFV(1,JF4).EQ.0) NFV(1,JF4)=NVOL
       IF (NFV(1,JF4).NE.NVOL) NFV(2,JF4)=NVOL
       IVOL(9,NVOL)=35
C
       DO 140 I=1,4
              IVOL(I,NVOL)=NFC(I,IF1)
140    CONTINUE
       IVOL(5,NVOL)=IP
*C
*       WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9)
*1100   FORMAT(I4,4X,14I4)
       if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,5)
1100   FORMAT(' COM443-1 facettes ',i5,' PYR5 ',8i5)
*C
*       DO 150 J=1,NPTMAX
*              WRITE(6,1110)J,(NPF(I,J),I=1,40)
*1110          FORMAT(I4,4X,40I3)
*150    CONTINUE
C  PV INC
C
 131    continue
        nfcini=nfcmax
C      2EME VOLUME : IF2+IP
C      --------------------
       IP1=ISUCC(IF2,II)
       IP2=ISUCC(IF2,IP1)
       IP3=ISUCC(IF2,IP2)
C
*     recherche existence de la face
       kf1=IFACE3(ip,ii,ip1)
*       IF (kf1.ne.0) write (6,*) ' com443 facette assimilee'
       IF (kf1.eq.0) THEN
        nfcmax=nfcmax+1
        kf1=nfcmax
        NFC(1,kf1)=ip
        NFC(2,kf1)=ii
        NFC(3,kf1)=ip1
        NFC(4,kf1)=0
       elseif (NFC(4,kf1).ne.0.or.ipred(kf1,ip).ne.ii) then
        kf1=0
       endif
*       write (6,*) ' com443 kf1 passe ',kf1
C
*     recherche existence de la face
       kf2=IFACE3(ip,ip1,ip2)
*       IF (kf2.ne.0) write (6,*) ' com443 facette assimilee'
       IF (kf2.eq.0) THEN
        nfcmax=nfcmax+1
        kf2=nfcmax
        NFC(1,kf2)=ip
        NFC(2,kf2)=ip1
        NFC(3,kf2)=ip2
        NFC(4,kf2)=0
       elseif (NFC(4,kf2).ne.0.or.ipred(kf2,ip).ne.ip1) then
        kf2=0
       endif
*       write (6,*) ' com443 kf2 passe ',kf2
C
*     recherche existence de la face
       kf3=IFACE3(ip,ip2,ip3)
*       IF (kf3.ne.0) write (6,*) ' com443 facette assimilee'
       IF (kf3.eq.0) THEN
        nfcmax=nfcmax+1
        kf3=nfcmax
        NFC(1,kf3)=ip
        NFC(2,kf3)=ip2
        NFC(3,kf3)=ip3
        NFC(4,kf3)=0
       elseif (NFC(4,kf3).ne.0.or.ipred(kf3,ip).ne.ip2) then
        kf3=0
       endif
*       write (6,*) ' com443 kf3 passe ',kf3
C
C     ON RETOMBE SUR JF1 (si on ne l'a pas detruit)
C
       kf4=IFACE3(ip,ip3,ii)
*       IF (kf4.ne.0) write (6,*) ' com443 facette deja existante'
       IF (kf4.eq.0) THEN
        nfcmax=nfcmax+1
        kf4=nfcmax
        NFC(1,kf4)=ip
        NFC(2,kf4)=ip3
        NFC(3,kf4)=ii
        NFC(4,kf4)=0
       elseif (NFC(4,kf4).ne.0.or.ipred(kf4,ip).ne.ip3) then
        kf4=0
       endif
*       write (6,*) ' com443 kf4 passe ',kf4
C
C
       if (diago(ip,ii,diacrd)) then
        kf4=0
        kf1=0
       endif
       if (diago(ip,ip1,diacrd)) then
        kf1=0
        kf2=0
       endif
       if (diago(ip,ip2,diacrd)) then
        kf2=0
        kf3=0
       endif
       if (diago(ip,ip3,diacrd)) then
        kf3=0
        kf4=0
       endif
       if (kf1*kf2*kf3*kf4.eq.0) then
*        write (6,*) 'com443 impossibilite '
        nfcmax=nfcini
        kf1=0
        kf2=0
        kf3=0
        kf4=0
        goto 161
       endif
       CALL REPSUB(IF2)
       CALL REPSUB(KF1)
       CALL REPSUB(KF2)
       CALL REPSUB(KF3)
       CALL REPSUB(KF4)
C
C      LE VOLUME CREE EST-IL VALIDE ?
C      ------------------------------
       if (.not.SOLPYR(IF2,KF1,KF2,KF3,KF4)) GOTO 160
       IF (.NOT.FACET(KF1)) GOTO 160
       IF (.NOT.FACET(KF2)) GOTO 160
       IF (.NOT.FACET(KF3)) GOTO 160
       IF (.NOT.FACET(KF4)) GOTO 160
       goto 170
C
160    CONTINUE
C
*      write (6,*) ' solpyr 2 invalide'
       NFCMAX=NFCini
       CALL REPSUB(KF4)
       CALL REPSUB(KF3)
       CALL REPSUB(KF2)
       CALL REPSUB(KF1)
       CALL REPSUB(IF2)
        kf1=0
        kf2=0
        kf3=0
        kf4=0
       goto 161
C
170    CONTINUE
C
C      MEMORISATION DU VOLUME IF2, LF1, KF2, KF3 ET LF4
C      ------------------------------------------------
       ICTV=ICTV+1
       NVOL=NVOL+1
       IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
       IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
       IF (NFV(1,kF1).EQ.0) NFV(1,kF1)=NVOL
       IF (NFV(1,kF1).NE.NVOL) NFV(2,kF1)=NVOL
       IF (NFV(1,kF2).EQ.0) NFV(1,kF2)=NVOL
       IF (NFV(1,kF2).NE.NVOL) NFV(2,kF2)=NVOL
       IF (NFV(1,kF3).EQ.0) NFV(1,kF3)=NVOL
       IF (NFV(1,kF3).NE.NVOL) NFV(2,kF3)=NVOL
       IF (NFV(1,kF4).EQ.0) NFV(1,kF4)=NVOL
       IF (NFV(1,kF4).NE.NVOL) NFV(2,kF4)=NVOL
       IVOL(9,NVOL)=35
C
       DO 180 I=1,4
              IVOL(I,NVOL)=NFC(I,IF2)
180    CONTINUE
       IVOL(5,NVOL)=IP
*       WRITE(6,1180)NVOL,(IVOL(I,NVOL),I=1,9)
*1180   FORMAT(I4,4X,14I4)
       if (iimpi.eq.1) write (6,1180) nfacet,(ivol(i,nvol),i=1,5)
1180   FORMAT(' COM443-2 facettes ',i5,' PYR5 ',8i5)
*C
*       DO 190 J=1,NPTMAX
*              WRITE(6,1190)J,(NPF(I,J),I=1,40)
*1190          FORMAT(I4,4X,40I3)
*190    CONTINUE
C
 161    continue
        nfcini=nfcmax
C
C      3EME VOLUME : IF3+IP
C      --------------------
      IP1=ISUCC(IF3,II)
      IP2=ISUCC(IF3,IP1)
C  ON RETOMBE SUR JF4  (si on ne l'a pas detruit)
C
       lf1=IFACE3(ip,ii,ip1)
*      IF (lf1.ne.0) write (6,*) ' com443 facette deja existante'
       IF (lf1.eq.0) THEN
        nfcmax=nfcmax+1
        lf1=nfcmax
        NFC(1,lf1)=ip
        NFC(2,lf1)=ii
        NFC(3,lf1)=ip1
        NFC(4,lf1)=0
       elseif (NFC(4,lf1).ne.0.or.ipred(lf1,ip).ne.ii) then
        lf1=0
       endif
*       write (6,*) ' com443 lf1 passe ',lf1
C
C
*     recherche existence de la face
       lf2=IFACE3(ip,ip1,ip2)
*       IF (lf2.ne.0) write (6,*) ' com443 facette assimilee'
       IF (lf2.eq.0) THEN
        nfcmax=nfcmax+1
        lf2=nfcmax
        NFC(1,lf2)=ip
        NFC(2,lf2)=ip1
        NFC(3,lf2)=ip2
        NFC(4,lf2)=0
       elseif (NFC(4,lf2).ne.0.or.ipred(lf2,ip).ne.ip1) then
        lf2=0
       endif
*       write (6,*) ' com443 lf2 passe ',lf2
C
C   ON RETOMBE SUR KF1  (si on ne l'a pas detruit)
C
       lf3=IFACE3(ip,ip2,ii)
*       IF (lf3.ne.0) write (6,*) ' com443 facette deja existante'
       IF (lf3.eq.0) THEN
        nfcmax=nfcmax+1
        lf3=nfcmax
        NFC(1,lf3)=ip
        NFC(2,lf3)=ip2
        NFC(3,lf3)=ii
        NFC(4,lf3)=0
       elseif (NFC(4,lf3).ne.0.or.ipred(lf3,ip).ne.ip2) then
        lf3=0
       endif
*       write (6,*) ' com443 lf3 passe ',lf3
C
       if (diago(ip,ii,diacrd)) then
        lf3=0
        lf1=0
       endif
       if (diago(ip,ip1,diacrd)) then
        lf1=0
        lf2=0
       endif
       if (diago(ip,ip2,diacrd)) then
        lf2=0
        lf3=0
       endif
       if (lf1*lf2*lf3.eq.0) then
*        write (6,*) 'com443 impossibilite '
        NFCMAX=NFCini
        goto 201
       endif
C
C
       CALL REPSUB(IF3)
       CALL REPSUB(LF1)
       CALL REPSUB(LF2)
       CALL REPSUB(LF3)
C
C      LE VOLUME CREE EST-IL VALIDE ?
C      ------------------------------
       IF (.NOT.SOLTET(IF3,LF1,LF2,LF3,ipin)) GOTO 200
       IF (.NOT.FACET(LF1)) GOTO 200
       IF (.NOT.FACET(LF2)) GOTO 200
       IF (.NOT.FACET(LF3)) GOTO 200
       GOTO 210
C
200    CONTINUE
*      write (6,*) ' soltet 3 invalide'
C
       NFCMAX=NFCini
       CALL REPSUB(LF3)
       CALL REPSUB(LF2)
       CALL REPSUB(LF1)
       CALL REPSUB(IF3)
       goto 201
C
210    CONTINUE
C
C      MEMORISATION DU VOLUME IF3, JF2, KF1, LF1 ET LF2
C      ------------------------------------------------
       ICTV=ICTV+1
       NVOL=NVOL+1
       IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
       IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
       IF (NFV(1,lF1).EQ.0) NFV(1,lF1)=NVOL
       IF (NFV(1,lF1).NE.NVOL) NFV(2,lF1)=NVOL
       IF (NFV(1,lF2).EQ.0) NFV(1,lF2)=NVOL
       IF (NFV(1,lF2).NE.NVOL) NFV(2,lF2)=NVOL
       IF (NFV(1,lF3).EQ.0) NFV(1,lF3)=NVOL
       IF (NFV(1,lF3).NE.NVOL) NFV(2,lF3)=NVOL
       IVOL(9,NVOL)=25
C
       DO 220 I=1,3
              IVOL(I,NVOL)=NFC(I,IF3)
220    CONTINUE
       IVOL(4,NVOL)=IP
*      WRITE(6,1240)NVOL,(IVOL(I,NVOL),I=1,9)
*1240   FORMAT(I4,4X,14I4)
       if (iimpi.eq.1) write (6,1240) nfacet,(ivol(i,nvol),i=1,4)
1240   FORMAT(' COM443-3 facettes ',i5,' TET4 ',8i5)
C
*      DO 230 J=1,NPTMAX
*             WRITE(6,1250)J,(NPF(I,J),I=1,40)
*1250          FORMAT(I4,4X,40I3)
*230    CONTINUE
C
 201    continue
        if (nvol.eq.nvini) then
          nptmax=nptini
          return
        endif
C
290    CONTINUE
C
*       if (iimpi.ne.0) write (6,*) ' comm443 point ',nptmax
       IGAGNE=1
*      CALL CONS33(IPRED(KF3,IP),IP,KF3,JF2,IGAG,1)
       RETURN
C
C      FIN DE LA SUBROUTINE COM443
       END