Numérotation des lignes :

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 CCOPTIO-INC TDEMAIT       LOGICAL REPONS,IN,in2,vervolCC       WRITE(6,1000)C1000   FORMAT(' *** DIAGO ***')C       REPONS=.FALSE.       DIAGO=.FALSE.       IFDIAG=0CC      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          RETURN110    CONTINUE100    CONTINUE200    CONTINUEC       DIAGO=REPONSC       IF (.NOT.REPONS) GOTO 300C       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

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