C PRISM1 SOURCE PV 07/10/08 21:15:12 5896 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,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 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 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) 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