C DIAGO SOURCE CB215821 17/11/30 21:15:59 9639 C---------------------------------------------------------------------| C | LOGICAL FUNCTION DIAGO(IP,JP,XCRIT) C | C CETTE FONCTION LOGIQUE VERIFIE QUE LE SEGMENT >IP,JP! | C CREE EST VALIDE. | C -1- CE SEGMENT NE DOIT PAS ETRE LA DIAGONALE D'UNE | C FACETTE CARREE DEJA EXISTANTE. | C -2- CE SEGMENT NE DOIT PAS ETRE TROP LONG | C | C---------------------------------------------------------------------| C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC TDEMAIT LOGICAL REPONS,IN,in2,vervol C C WRITE(6,1000) C1000 FORMAT(' *** DIAGO ***') C REPONS=.FALSE. DIAGO=.FALSE. IFDIAG=0 C C LE SEGMENT APPARTIENT-IL A UNE FACETTE CARREE ? C QUESTION SUBSIDIAIRE EXISTE-T-IL DEJA ??? | C ----------------------------------------------- DO 100 I=1,40 JF=NPF(I,IP) IF (JF.EQ.0) GOTO 200 DO 110 J=1,40 IF (NPF(J,JP).EQ.0) GOTO 100 IF (JF.NE.NPF(J,JP)) GOTO 110 * LE SEGMENT EST UNE ARETE D'UNE FACETTE TRIANGULAIRE ==> OK IF (NFC(4,JF).EQ.0) RETURN IF (IP.EQ.NFC(1,JF).AND.JP.EQ.NFC(3,JF)) REPONS=.TRUE. IF (IP.EQ.NFC(3,JF).AND.JP.EQ.NFC(1,JF)) REPONS=.TRUE. IF (IP.EQ.NFC(2,JF).AND.JP.EQ.NFC(4,JF)) REPONS=.TRUE. IF (IP.EQ.NFC(4,JF).AND.JP.EQ.NFC(2,JF)) REPONS=.TRUE. IF (REPONS) GOTO 200 * LE SEGMENT EST UNE ARETE D'UNE FACETTE QUADRANGULAIRE ==> OK RETURN 110 CONTINUE 100 CONTINUE 200 CONTINUE C DIAGO=REPONS C IF (.NOT.REPONS) GOTO 300 C IF (IVERB.EQ.1) WRITE(6,1010)IP,JP,JF,nfc(1,jf),nfc(2,jf), # nfc(3,jf) 1010 FORMAT(' LE SEGMENT >',I3,',',I3,'! APPARTIENT A LA FACETTE ', # I3,3i5) C RETURN * * TEST QUE L'ARETE N'EST PAS INSCRITE DANS UNE FACETTE * 300 CONTINUE * test pour voir si l'arete est dans le volume a mailler * premier test rapide par les volumes aux facettes issues du sommet * en cas d'echec test supplementaire DO 900 I=1,40 JF=NPF(I,IP) IF (JF.EQ.0) GOTO 901 if (vol(jp,nfc(1,jf),nfc(2,jf),nfc(3,jf)).gt.0.d0) goto 950 if (nfc(4,jf).eq.0) goto 900 if (vol(jp,nfc(1,jf),nfc(3,jf),nfc(4,jf)).gt.0.d0) goto 950 900 continue 901 continue DO 910 I=1,40 JF=NPF(I,JP) IF (JF.EQ.0) GOTO 911 if (vol(ip,nfc(1,jf),nfc(2,jf),nfc(3,jf)).gt.0.d0) goto 950 if (nfc(4,jf).eq.0) goto 910 if (vol(ip,nfc(1,jf),nfc(3,jf),nfc(4,jf)).gt.0.d0) goto 950 910 continue 911 continue goto 960 950 continue * write (6,*) ' tests complementaires ' do 3 i=1,4 xyz(i,nptmax+1)=0.99d0*xyz(i,ip)+0.01d0*xyz(i,jp) xyz(i,nptmax+2)=0.01d0*xyz(i,ip)+0.99d0*xyz(i,jp) 3 continue diago=.not.vervol(nptmax+1,ip,ip,-1,-1,-1,-1,-1,-1) if (diago) return diago=.not.vervol(nptmax+1,jp,jp,-1,-1,-1,-1,-1,-1) if (diago) return 960 continue XIP=XYZ(1,IP) YIP=XYZ(2,IP) ZIP=XYZ(3,IP) XJP=XYZ(1,JP) YJP=XYZ(2,JP) ZJP=XYZ(3,JP) DO 310 I=1,40 IF=NPF(I,IP) IF (IF.EQ.0) GOTO 315 II=ISUCC(IF,IP) IF (II.EQ.JP) GOTO 310 JJ=IPRED(IF,IP) IF (JJ.EQ.JP) GOTO 310 XII=XYZ(1,II)-XIP YII=XYZ(2,II)-YIP ZII=XYZ(3,II)-ZIP VII=SQRT(XII**2+YII**2+ZII**2) XII=XII/VII YII=YII/VII ZII=ZII/VII XJJ=XYZ(1,JJ)-XIP YJJ=XYZ(2,JJ)-YIP ZJJ=XYZ(3,JJ)-ZIP VJJ=SQRT(XJJ**2+YJJ**2+ZJJ**2) XJJ=XJJ/VJJ YJJ=YJJ/VJJ ZJJ=ZJJ/VJJ * (IP,JP)^(IP,II) XN1=(YJP-YIP)* ZII -(ZJP-ZIP)* YII YN1=(ZJP-ZIP)* XII -(XJP-XIP)* ZII ZN1=(XJP-XIP)* YII -(YJP-YIP)* XII VN1=SQRT(XN1**2+YN1**2+ZN1**2) * (IP,JP)^(IP,JJ) XN2=(YJP-YIP)* ZJJ -(ZJP-ZIP)* YJJ YN2=(ZJP-ZIP)* XJJ -(XJP-XIP)* ZJJ ZN2=(XJP-XIP)* YJJ -(YJP-YIP)* XJJ VN2=SQRT(XN2**2+YN2**2+ZN2**2) IF((XJP-XIP)*(XII+XJJ)+(YJP-YIP)*(YII+YJJ)+ # (ZJP-ZIP)*(ZII+ZJJ).LT.0.d0) GOTO 310 SCAL=XN1*XN2+YN1*YN2+ZN1*ZN2 IF (SCAL.LT.-xcrit*VN1*VN2) THEN if (iimpi.ne.0) > WRITE (6,*) ' DIAGO-1 ',IP,JP,' EST DANS ',IF, > nfc(1,if),nfc(2,if),nfc(3,if) DIAGO=.TRUE. ifdiag=if RETURN ENDIF 310 CONTINUE 315 CONTINUE DO 320 I=1,40 IF=NPF(I,JP) IF (IF.EQ.0) GOTO 325 II=ISUCC(IF,JP) IF (II.EQ.IP) GOTO 320 JJ=IPRED(IF,JP) IF (JJ.EQ.IP) GOTO 320 XII=XYZ(1,II)-XJP YII=XYZ(2,II)-YJP ZII=XYZ(3,II)-ZJP VII=SQRT(XII**2+YII**2+ZII**2) XII=XII/VII YII=YII/VII ZII=ZII/VII XJJ=XYZ(1,JJ)-XJP YJJ=XYZ(2,JJ)-YJP ZJJ=XYZ(3,JJ)-ZJP VJJ=SQRT(XJJ**2+YJJ**2+ZJJ**2) XJJ=XJJ/VJJ YJJ=YJJ/VJJ ZJJ=ZJJ/VJJ * (JP,IP)^(JP,II) XN1=(YIP-YJP)* ZII -(ZIP-ZJP)* YII YN1=(ZIP-ZJP)* XII -(XIP-XJP)* ZII ZN1=(XIP-XJP)* YII -(YIP-YJP)* XII VN1=SQRT(XN1**2+YN1**2+ZN1**2) * (JP,IP)^(JP,JJ) XN2=(YIP-YJP)* ZJJ -(ZIP-ZJP)* YJJ YN2=(ZIP-ZJP)* XJJ -(XIP-XJP)* ZJJ ZN2=(XIP-XJP)* YJJ -(YIP-YJP)* XJJ VN2=SQRT(XN2**2+YN2**2+ZN2**2) IF((XIP-XJP)*(XII+XJJ)+(YIP-YJP)*(YII+YJJ)+ # (ZIP-ZJP)*(ZII+ZJJ).LT.0d0) GOTO 320 SCAL=XN1*XN2+YN1*YN2+ZN1*ZN2 IF (SCAL.LT.-xcrit*VN1*VN2) THEN if (iimpi.ne.0) > WRITE (6,*) ' DIAGO-2 ',JP,IP,' EST DANS ',IF, > nfc(1,if),nfc(2,if),nfc(3,if) ifdiag=if DIAGO=.TRUE. RETURN ENDIF 320 CONTINUE 325 CONTINUE * VERIFICATION DES DISTANCES AVEC LES AUTRES ARETES RENTRANTES * RECHERCHE SI ARETE EXISTE DEJA DO 500 I=1,40 IF=NPF(I,IP) IF (IF.EQ.0) GOTO 501 DO 502 J=1,40 JF=NPF(J,JP) IF (JF.EQ.0) GOTO 500 IF (IF.EQ.JF) GOTO 800 502 CONTINUE 500 CONTINUE 501 CONTINUE XP1=XYZ(1,IP) YP1=XYZ(2,IP) ZP1=XYZ(3,IP) XP2=XYZ(1,JP) YP2=XYZ(2,JP) ZP2=XYZ(3,JP) DP=(XP1-XP2)**2+(YP1-YP2)**2+(ZP1-ZP2)**2 XP3=(XP1+XP2)/2.d0 YP3=(YP1+YP2)/2.d0 ZP3=(ZP1+ZP2)/2.d0 * TEST AVEC LES AUTRES ARETES POSSIBLES goto 800 do 520 ipt=ip,jp,jp-ip DO 510 I=1,40 IF=NPF(I,IPT) if (IF.EQ.0) goto 520 kp=isucc(if,ipt) IF (IP.EQ.KP) GOTO 510 IF (JP.EQ.KP) GOTO 510 do 511 J=1,40 jf=npf(j,kp) if (jF.EQ.0) goto 510 lp=isucc(jf,kp) IF (IP.EQ.LP) GOTO 511 IF (JP.EQ.LP) GOTO 511 XQ1=XYZ(1,KP) YQ1=XYZ(2,KP) ZQ1=XYZ(3,KP) XQ2=XYZ(1,LP) YQ2=XYZ(2,LP) ZQ2=XYZ(3,LP) DQ=(XQ1-XQ2)**2+(YQ1-YQ2)**2+(ZQ1-ZQ2)**2 XQ3=(XQ1+XQ2)/2.d0 YQ3=(YQ1+YQ2)/2.d0 ZQ3=(ZQ1+ZQ2)/2.d0 dmin=min(dp,dq)/64d0 * DT=(XP1-XQ1)**2+(YP1-YQ1)**2+(ZP1-ZQ1)**2 * IF (DT.LE.dmin) GOTO 810 * DT=(XP1-XQ2)**2+(YP1-YQ2)**2+(ZP1-ZQ2)**2 * IF (DT.LE.dmin) GOTO 810 * DT=(XP1-XQ3)**2+(YP1-YQ3)**2+(ZP1-ZQ3)**2 * IF (DT.LE.dmin) GOTO 810 * DT=(XP2-XQ1)**2+(YP2-YQ1)**2+(ZP2-ZQ1)**2 * IF (DT.LE.dmin) GOTO 810 * DT=(XP2-XQ2)**2+(YP2-YQ2)**2+(ZP2-ZQ2)**2 * IF (DT.LE.dmin) GOTO 810 * DT=(XP2-XQ3)**2+(YP2-YQ3)**2+(ZP2-ZQ3)**2 * IF (DT.LE.dmin) GOTO 810 DT=(XP3-XQ1)**2+(YP3-YQ1)**2+(ZP3-ZQ1)**2 IF (DT.LE.dmin) GOTO 810 DT=(XP3-XQ2)**2+(YP3-YQ2)**2+(ZP3-ZQ2)**2 IF (DT.LE.dmin) GOTO 810 DT=(XP3-XQ3)**2+(YP3-YQ3)**2+(ZP3-ZQ3)**2 IF (DT.LE.dmin) GOTO 810 511 continue 510 CONTINUE 520 CONTINUE 800 CONTINUE DIAGO=.FALSE. RETURN 810 CONTINUE DIAGO=.TRUE. IFDIAG=JF if (iimpi.ne.0) >WRITE (6,*) ' ARETE TROP PROCHES ',IP,JP,KP,LP,dt,dmin * WRITE (6,*) 'xp1,yp1,zp1 ',xp1,yp1,zp1 * WRITE (6,*) 'xp2,yp2,zp2 ',xp2,yp2,zp2 * WRITE (6,*) 'xp3,yp3,zp3 ',xp3,yp3,zp3 * WRITE (6,*) 'xq1,yq1,zq1 ',xq1,yq1,zq1 * WRITE (6,*) 'xq2,yq2,zq2 ',xq2,yq2,zq2 * WRITE (6,*) 'xq3,yq3,zq3 ',xq3,yq3,zq3 RETURN END