Numérotation des lignes :

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 CCOPTIO       LOGICAL REPONS,FACET,SOLPRI,SOLPYR,SOLTET,DIAGO,IN,PLANC*      WRITE(6,*) ' PRISM1 ',ii,jj,if1,if2C*      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=0CC      RECHERCHE DE LA FACETTE IF3C      ---------------------------C       IF3=IFACE3(ISUCC(IF2,II),II,IPRED(IF1,II))*      IF (IF3.NE.0) WRITE(6,1010)IF31010      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=2C  FACE PAS TRIANGULAIRE       ENDIFCC      RECHERCHE DE LA FACETTE IF4C      ---------------------------C       IF4=IFACE3(IPRED(IF2,JJ),JJ,ISUCC(IF1,JJ))*      IF (IF4.NE.0) WRITE(6,1020)IF41020      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=2C  FACE PAS TRIANGULAIRE       ENDIF       IF (N3.EQ.2.OR.N4.EQ.2) GOTO 9000CCC      RECHERCHE DE LA FACETTE IF5C      ---------------------------C       IF5=IFACE4(ISUCC(IF1,JJ),IPRED(IF1,II),     #  ISUCC(IF2,II),IPRED(IF2,JJ))*      IF (IF5.NE.0) WRITE(6,1030) IF51030      FORMAT(' **IF5=',I3)       IF (IF5.LT.0) GOTO 9000       IF (IF5.NE.0)  N5=1CC        IF (DIAGO(IPRED(IF1,II),ISUCC(IF2,II),0.95d0)) GOTO 9000*  DIAGONALE QUADRILATEREC        IF (DIAGO(IPRED(IF2,JJ),ISUCC(IF1,JJ),0.95d0)) GOTO 9000*  DIAGONALE QUADRILATERECCC      CONSTRUCTION DU PRISMEC      ----------------------C       IF (IF3.EQ.0) THENCC      CREATION DE LA FACETTE IF3C      --------------------------       NFCMAX=NFCMAX+1       IF3=NFCMAX       ICTF=ICTF+1C       NFC(1,IF3)=IPRED(IF1,II)       NFC(2,IF3)=II       NFC(3,IF3)=ISUCC(IF2,II)       NFC(4,IF3)=0C       ENDIFCC       IF (IF4.EQ.0) THENCC      CREATION DE LA FACETTE IF4C      --------------------------       NFCMAX=NFCMAX+1       IF4=NFCMAX       ICTF=ICTF+1C       NFC(1,IF4)=JJ       NFC(2,IF4)=ISUCC(IF1,JJ)       NFC(3,IF4)=IPRED(IF2,JJ)       NFC(4,IF4)=0C       ENDIFCC       IF (IF5.EQ.0)  THENCC      CREATION DE LA FACETTE IF5C      --------------------------       NFCMAX=NFCMAX+1       IF5=NFCMAX       ICTF=ICTF+1C       NFC(1,IF5)=IPRED(IF2,JJ)       NFC(2,IF5)=ISUCC(IF1,JJ)       NFC(3,IF5)=IPRED(IF1,II)       NFC(4,IF5)=ISUCC(IF2,II)CC       ENDIFCC      ON ENLEVE LES FACETTES IF1, IF2 ET IF3C      --------------------------------------       CALL REPSUB(IF1)       CALL REPSUB(IF2)       CALL REPSUB(IF3)       CALL REPSUB(IF4)       CALL REPSUB(IF5)CC      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       endifCC      LE VOLUME CREE EST VALIDE |C      ---------------------------C      MEMORISATION DU VOLUME IF1, IF2, IF3, IF4 ET IF5C      ------------------------------------------------       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    CONTINUEC       IGAGNE=1C       RETURNC160    CONTINUECC      LE VOLUME CREE N'EST PAS VALIDE: IL FAUT DONC DETRUIRE LES FACETTC      CREEES. ---------------------------------------------------------       CALL REPSUB(IF1)       CALL REPSUB(IF2)       CALL REPSUB(IF3)       CALL REPSUB(IF4)       CALL REPSUB(IF5)C       NFCMAX=NFCMAX-ICTFC       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

© Cast3M 2003 - Tous droits réservés.
Mentions légales