Sources Esope | Cast3M

prism1
C PRISM1    SOURCE    JC220346  16/11/29    21:15:29     9221           
C---------------------------------------------------------------------|
C                                                                     |
       SUBROUTINE PRISM1(II,JJ,IF1,IF2,IGAGNE)
C                                                                     |
C      CETTE SUBROUTINE TENTE DE CREER UN PRISME A PARTIR             |
C      DES QUADRANGLES IF1 ET IF2.                                    |
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,SOLPRI,SOLPYR,SOLTET,DIAGO,IN,PLAN
C
*      WRITE(6,*) ' PRISM1 ',ii,jj,if1,if2
C
*      write (6,*) ' liste des facettes restantes '
*      DO 444 I=1,NFCMAX
*       IF (IFAT(I).EQ.1) GOTO 444
*       WRITE (6,*)  I,NFC(1,I),NFC(2,I),NFC(3,I),NFC(4,I)
*444  CONTINUE
       N3=0
       N4=0
       N5=0
       ICTF=0
       ICTV=0
C
C      RECHERCHE DE LA FACETTE IF3
C      ---------------------------
C
       IF3=IFACE3(ISUCC(IF2,II),II,IPRED(IF1,II))
*      IF (IF3.NE.0) WRITE(6,1010)IF3
1010      FORMAT(' ** IF3=',I3)
C
       IF (IF3.NE.0) THEN
*  si if3 dans le mauvais sens rien a faire
       if (isucc(if3,ii).ne.iPRED(IF1,II)) then
        IF (IVERB.EQ.1) write (6,*) ' prism1 face a l''envers if3 '
        return
       endif
        N3=1
        IF(NFC(4,IF3).NE.0) N3=2
C  FACE PAS TRIANGULAIRE
       ENDIF
C
C      RECHERCHE DE LA FACETTE IF4
C      ---------------------------
C
       IF4=IFACE3(IPRED(IF2,JJ),JJ,ISUCC(IF1,JJ))
*      IF (IF4.NE.0) WRITE(6,1020)IF4
1020      FORMAT(' ** IF4=',I3)
C
       IF (IF4.NE.0) THEN
*  si if4 dans le mauvais sens rien a faire
       if (isucc(if4,jj).ne.iPRED(IF2,jj)) then
        IF (IVERB.EQ.1) write (6,*) ' prism1 face a l''envers if4 '
        return
       endif
        N4=1
        IF(NFC(4,IF4).NE.0) N4=2
C  FACE PAS TRIANGULAIRE
       ENDIF
       IF (N3.EQ.2.OR.N4.EQ.2) GOTO 9000
C
C
C      RECHERCHE DE LA FACETTE IF5
C      ---------------------------
C
       IF5=IFACE4(ISUCC(IF1,JJ),IPRED(IF1,II),
     #  ISUCC(IF2,II),IPRED(IF2,JJ))
*      IF (IF5.NE.0) WRITE(6,1030) IF5
1030      FORMAT(' **IF5=',I3)
       IF (IF5.LT.0) GOTO 9000
       IF (IF5.NE.0)  N5=1
C
C
        IF (DIAGO(IPRED(IF1,II),ISUCC(IF2,II),0.95d0)) GOTO 9000
*  DIAGONALE QUADRILATERE
C
        IF (DIAGO(IPRED(IF2,JJ),ISUCC(IF1,JJ),0.95d0)) GOTO 9000
*  DIAGONALE QUADRILATERE
C
C
C      CONSTRUCTION DU PRISME
C      ----------------------
C
       IF (IF3.EQ.0) THEN
C
C      CREATION DE LA FACETTE IF3
C      --------------------------
       NFCMAX=NFCMAX+1
       IF3=NFCMAX
       ICTF=ICTF+1
C
       NFC(1,IF3)=IPRED(IF1,II)
       NFC(2,IF3)=II
       NFC(3,IF3)=ISUCC(IF2,II)
       NFC(4,IF3)=0
C
       ENDIF
C
C
       IF (IF4.EQ.0) THEN
C
C      CREATION DE LA FACETTE IF4
C      --------------------------
       NFCMAX=NFCMAX+1
       IF4=NFCMAX
       ICTF=ICTF+1
C
       NFC(1,IF4)=JJ
       NFC(2,IF4)=ISUCC(IF1,JJ)
       NFC(3,IF4)=IPRED(IF2,JJ)
       NFC(4,IF4)=0
C
       ENDIF
C
C
       IF (IF5.EQ.0)  THEN
C
C      CREATION DE LA FACETTE IF5
C      --------------------------
       NFCMAX=NFCMAX+1
       IF5=NFCMAX
       ICTF=ICTF+1
C
       NFC(1,IF5)=IPRED(IF2,JJ)
       NFC(2,IF5)=ISUCC(IF1,JJ)
       NFC(3,IF5)=IPRED(IF1,II)
       NFC(4,IF5)=ISUCC(IF2,II)
C
C
       ENDIF
C
C      ON ENLEVE LES FACETTES IF1, IF2 ET IF3
C      --------------------------------------
       CALL REPSUB(IF1)
       CALL REPSUB(IF2)
       CALL REPSUB(IF3)
       CALL REPSUB(IF4)
       CALL REPSUB(IF5)
C
C      LE VOLUME CREE EST-IL VALIDE ?
C      ------------------------------
       IF (.NOT.PLAN(IF5)) GOTO 160
       IF (.NOT.FACET(IF3)) GOTO 160
       IF (.NOT.FACET(IF4)) GOTO 160
       IF (.NOT.FACET(IF5)) GOTO 160
       IF (.NOT.SOLPRI(IF1,IF2,IF3,IF4,IF5)) GOTO 160
*
*  VERIFICATION TAILLE
       IF (N3.EQ.0.AND.N5.EQ.0) THEN
        KF1=IPRED(IF1,II)
        KF2=ISUCC(IF2,II)
         DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2
     #        +(XYZ(2,KF1)-XYZ(2,KF2))**2
     #        +(XYZ(3,KF1)-XYZ(3,KF2))**2
         DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2)
         IF (DNORM.GT.DTEST) GOTO 160
       ENDIF
       IF (N4.EQ.0.AND.N5.EQ.0) THEN
        KF1=IPRED(IF2,JJ)
        KF2=ISUCC(IF1,JJ)
         DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2
     #        +(XYZ(2,KF1)-XYZ(2,KF2))**2
     #        +(XYZ(3,KF1)-XYZ(3,KF2))**2
         DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2)
         IF (DNORM.GT.DTEST) GOTO 160
       ENDIF
*   verification complementaire sur la facette if5
       if (n5.eq.0) then
       do 200 i=1,4
        xyz(i,nptmax+1)=0.
        do 210 j=1,4
         xyz(i,nptmax+1)=xyz(i,nptmax+1)+xyz(i,nfc(j,if5))
 210    continue
        xyz(i,nptmax+1)=xyz(i,nptmax+1)/4.d0
 200   continue
        CALL DIST(nptmax+1,KP,GL,IOK,II,JJ,nfc(1,if5),nfc(2,if5),
     >                nfc(3,if5),nfc(4,if5),0,0,0,0)
        if (iok.eq.0.AND.IVERB.EQ.1) write (6,*) ' prism1 echec dist'
        if (iok.eq.0) goto 160
       endif
C
C      LE VOLUME CREE EST VALIDE |
C      ---------------------------
C      MEMORISATION DU VOLUME IF1, IF2, IF3, IF4 ET IF5
C      ------------------------------------------------
       NVOL=NVOL+1
       IVOL(9,NVOL)=30
       IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
       IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
       IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
       IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=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
       IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL
       IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL
       IVOL(1,NVOL)=II
       IVOL(2,NVOL)=IPRED(IF1,II)
       IVOL(3,NVOL)=ISUCC(IF2,II)
       IVOL(4,NVOL)=JJ
       IVOL(5,NVOL)=ISUCC(IF1,JJ)
       IVOL(6,NVOL)=IPRED(IF2,JJ)
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,6)
1100   FORMAT(' PRISM1 facettes ',i5,' pri6 ',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
       IGAGNE=1
C
       RETURN
C
160    CONTINUE
C
C      LE VOLUME CREE N'EST PAS VALIDE: IL FAUT DONC DETRUIRE LES FACETT
C      CREEES. ---------------------------------------------------------
       CALL REPSUB(IF1)
       CALL REPSUB(IF2)
       CALL REPSUB(IF3)
       CALL REPSUB(IF4)
       CALL REPSUB(IF5)
C
       NFCMAX=NFCMAX-ICTF
C
       GOTO 9000
 9000  CONTINUE
*  on va d'abord betement essayer de mettre 2 pyramides en rajoutant
*  un point
       call pyra3(II,JJ,IF1,IF2,IGAGNE)
       IF (IGAGNE.EQ.1) RETURN
       IF (N3.NE.0) CALL COMBL3(II,IF1,IF2,IF3,IGAGNE)
       IF (IGAGNE.EQ.1) RETURN
       IF (N4.NE.0) CALL COMBL3(JJ,IF2,IF1,IF4,IGAGNE)
       RETURN
       END