Télécharger la plaquette Cast3M


fr en

Télécharger diago.eso

Retour à la liste

Numérotation des lignes : 

diago

  1. C DIAGO     SOURCE    CB215821  17/11/30    21:15:59     9639           
  2. C---------------------------------------------------------------------|
  3. C                                                                     |
  4.        LOGICAL FUNCTION DIAGO(IP,JP,XCRIT)
  5. C                                                                     |
  6. C      CETTE FONCTION LOGIQUE VERIFIE QUE LE SEGMENT >IP,JP!          |
  7. C      CREE EST VALIDE.                                               |
  8. C      -1-    CE SEGMENT NE DOIT PAS ETRE LA DIAGONALE D'UNE          |
  9. C             FACETTE CARREE DEJA EXISTANTE.                          |
  10. C      -2-    CE SEGMENT NE DOIT PAS ETRE TROP LONG                   |
  11. C                                                                     |
  12. C---------------------------------------------------------------------|
  13. C
  14.       IMPLICIT INTEGER(I-N)
  15.       IMPLICIT REAL*8(A-H,O-Z)
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC TDEMAIT
  20.        LOGICAL REPONS,IN,in2,vervol
  21. C
  22. C       WRITE(6,1000)
  23. C1000   FORMAT(' *** DIAGO ***')
  24. C
  25.        REPONS=.FALSE.
  26.        DIAGO=.FALSE.
  27.        IFDIAG=0
  28. C
  29. C      LE SEGMENT APPARTIENT-IL A UNE FACETTE CARREE ?
  30. C      QUESTION SUBSIDIAIRE EXISTE-T-IL DEJA ???     |
  31. C      -----------------------------------------------
  32.        DO 100 I=1,40
  33.         JF=NPF(I,IP)
  34.           IF (JF.EQ.0) GOTO 200
  35.           DO 110 J=1,40
  36.              IF (NPF(J,JP).EQ.0) GOTO 100
  37.              IF (JF.NE.NPF(J,JP)) GOTO 110
  38. *  LE SEGMENT EST UNE ARETE D'UNE FACETTE TRIANGULAIRE ==> OK
  39.              IF (NFC(4,JF).EQ.0) RETURN
  40.              IF (IP.EQ.NFC(1,JF).AND.JP.EQ.NFC(3,JF)) REPONS=.TRUE.
  41.              IF (IP.EQ.NFC(3,JF).AND.JP.EQ.NFC(1,JF)) REPONS=.TRUE.
  42.              IF (IP.EQ.NFC(2,JF).AND.JP.EQ.NFC(4,JF)) REPONS=.TRUE.
  43.              IF (IP.EQ.NFC(4,JF).AND.JP.EQ.NFC(2,JF)) REPONS=.TRUE.
  44.           IF (REPONS) GOTO 200
  45. *  LE SEGMENT EST UNE ARETE D'UNE FACETTE QUADRANGULAIRE ==> OK
  46.           RETURN
  47. 110    CONTINUE
  48. 100    CONTINUE
  49. 200    CONTINUE
  50. C
  51.        DIAGO=REPONS
  52. C
  53.        IF (.NOT.REPONS) GOTO 300
  54. C
  55.        IF (IVERB.EQ.1) WRITE(6,1010)IP,JP,JF,nfc(1,jf),nfc(2,jf),
  56.      #          nfc(3,jf)
  57. 1010   FORMAT(' LE SEGMENT >',I3,',',I3,'! APPARTIENT A LA FACETTE ',
  58.      #         I3,3i5)
  59. C
  60.        RETURN
  61. *
  62. *    TEST QUE L'ARETE N'EST PAS INSCRITE DANS UNE FACETTE
  63. *
  64.  300  CONTINUE
  65. *  test pour voir si l'arete est dans le volume a mailler
  66. *  premier test rapide par les volumes aux facettes issues du sommet
  67. *  en cas d'echec test supplementaire
  68.        DO 900 I=1,40
  69.         JF=NPF(I,IP)
  70.           IF (JF.EQ.0) GOTO 901
  71.            if (vol(jp,nfc(1,jf),nfc(2,jf),nfc(3,jf)).gt.0.d0) goto 950
  72.            if (nfc(4,jf).eq.0) goto 900
  73.            if (vol(jp,nfc(1,jf),nfc(3,jf),nfc(4,jf)).gt.0.d0) goto 950
  74.  900  continue
  75.  901  continue
  76.        DO 910 I=1,40
  77.         JF=NPF(I,JP)
  78.           IF (JF.EQ.0) GOTO 911
  79.            if (vol(ip,nfc(1,jf),nfc(2,jf),nfc(3,jf)).gt.0.d0) goto 950
  80.            if (nfc(4,jf).eq.0) goto 910
  81.            if (vol(ip,nfc(1,jf),nfc(3,jf),nfc(4,jf)).gt.0.d0) goto 950
  82.  910  continue
  83.  911  continue
  84.        goto 960
  85.  950   continue
  86. *      write (6,*) ' tests complementaires '
  87.        do 3 i=1,4
  88.         xyz(i,nptmax+1)=0.99d0*xyz(i,ip)+0.01d0*xyz(i,jp)
  89.         xyz(i,nptmax+2)=0.01d0*xyz(i,ip)+0.99d0*xyz(i,jp)
  90.    3   continue
  91.        diago=.not.vervol(nptmax+1,ip,ip,-1,-1,-1,-1,-1,-1)
  92.        if (diago) return
  93.        diago=.not.vervol(nptmax+1,jp,jp,-1,-1,-1,-1,-1,-1)
  94.        if (diago) return
  95.  960   continue
  96.       XIP=XYZ(1,IP)
  97.       YIP=XYZ(2,IP)
  98.       ZIP=XYZ(3,IP)
  99.       XJP=XYZ(1,JP)
  100.       YJP=XYZ(2,JP)
  101.       ZJP=XYZ(3,JP)
  102.       DO 310 I=1,40
  103.       IF=NPF(I,IP)
  104.       IF (IF.EQ.0) GOTO 315
  105.        II=ISUCC(IF,IP)
  106.         IF (II.EQ.JP) GOTO 310
  107.        JJ=IPRED(IF,IP)
  108.         IF (JJ.EQ.JP) GOTO 310
  109.       XII=XYZ(1,II)-XIP
  110.       YII=XYZ(2,II)-YIP
  111.       ZII=XYZ(3,II)-ZIP
  112.       VII=SQRT(XII**2+YII**2+ZII**2)
  113.       XII=XII/VII
  114.       YII=YII/VII
  115.       ZII=ZII/VII
  116.       XJJ=XYZ(1,JJ)-XIP
  117.       YJJ=XYZ(2,JJ)-YIP
  118.       ZJJ=XYZ(3,JJ)-ZIP
  119.       VJJ=SQRT(XJJ**2+YJJ**2+ZJJ**2)
  120.       XJJ=XJJ/VJJ
  121.       YJJ=YJJ/VJJ
  122.       ZJJ=ZJJ/VJJ
  123. *  (IP,JP)^(IP,II)
  124.       XN1=(YJP-YIP)* ZII     -(ZJP-ZIP)* YII
  125.       YN1=(ZJP-ZIP)* XII     -(XJP-XIP)* ZII
  126.       ZN1=(XJP-XIP)* YII     -(YJP-YIP)* XII
  127.       VN1=SQRT(XN1**2+YN1**2+ZN1**2)
  128. *  (IP,JP)^(IP,JJ)
  129.       XN2=(YJP-YIP)* ZJJ     -(ZJP-ZIP)* YJJ
  130.       YN2=(ZJP-ZIP)* XJJ     -(XJP-XIP)* ZJJ
  131.       ZN2=(XJP-XIP)* YJJ     -(YJP-YIP)* XJJ
  132.       VN2=SQRT(XN2**2+YN2**2+ZN2**2)
  133.       IF((XJP-XIP)*(XII+XJJ)+(YJP-YIP)*(YII+YJJ)+
  134.      #   (ZJP-ZIP)*(ZII+ZJJ).LT.0.d0) GOTO 310
  135.       SCAL=XN1*XN2+YN1*YN2+ZN1*ZN2
  136.       IF (SCAL.LT.-xcrit*VN1*VN2) THEN
  137.       if (iimpi.ne.0)
  138.      > WRITE (6,*) ' DIAGO-1 ',IP,JP,' EST DANS ',IF,
  139.      >  nfc(1,if),nfc(2,if),nfc(3,if)
  140.        DIAGO=.TRUE.
  141.        ifdiag=if
  142.        RETURN
  143.       ENDIF
  144.  310  CONTINUE
  145.  315  CONTINUE
  146.       DO 320 I=1,40
  147.       IF=NPF(I,JP)
  148.       IF (IF.EQ.0) GOTO 325
  149.        II=ISUCC(IF,JP)
  150.         IF (II.EQ.IP) GOTO 320
  151.        JJ=IPRED(IF,JP)
  152.         IF (JJ.EQ.IP) GOTO 320
  153.       XII=XYZ(1,II)-XJP
  154.       YII=XYZ(2,II)-YJP
  155.       ZII=XYZ(3,II)-ZJP
  156.       VII=SQRT(XII**2+YII**2+ZII**2)
  157.       XII=XII/VII
  158.       YII=YII/VII
  159.       ZII=ZII/VII
  160.       XJJ=XYZ(1,JJ)-XJP
  161.       YJJ=XYZ(2,JJ)-YJP
  162.       ZJJ=XYZ(3,JJ)-ZJP
  163.       VJJ=SQRT(XJJ**2+YJJ**2+ZJJ**2)
  164.       XJJ=XJJ/VJJ
  165.       YJJ=YJJ/VJJ
  166.       ZJJ=ZJJ/VJJ
  167. *  (JP,IP)^(JP,II)
  168.       XN1=(YIP-YJP)* ZII     -(ZIP-ZJP)* YII
  169.       YN1=(ZIP-ZJP)* XII     -(XIP-XJP)* ZII
  170.       ZN1=(XIP-XJP)* YII     -(YIP-YJP)* XII
  171.       VN1=SQRT(XN1**2+YN1**2+ZN1**2)
  172. *  (JP,IP)^(JP,JJ)
  173.       XN2=(YIP-YJP)* ZJJ     -(ZIP-ZJP)* YJJ
  174.       YN2=(ZIP-ZJP)* XJJ     -(XIP-XJP)* ZJJ
  175.       ZN2=(XIP-XJP)* YJJ     -(YIP-YJP)* XJJ
  176.       VN2=SQRT(XN2**2+YN2**2+ZN2**2)
  177.       IF((XIP-XJP)*(XII+XJJ)+(YIP-YJP)*(YII+YJJ)+
  178.      #   (ZIP-ZJP)*(ZII+ZJJ).LT.0d0) GOTO 320
  179.       SCAL=XN1*XN2+YN1*YN2+ZN1*ZN2
  180.       IF (SCAL.LT.-xcrit*VN1*VN2) THEN
  181.       if (iimpi.ne.0)
  182.      > WRITE (6,*) ' DIAGO-2 ',JP,IP,' EST DANS ',IF,
  183.      >  nfc(1,if),nfc(2,if),nfc(3,if)
  184.        ifdiag=if
  185.        DIAGO=.TRUE.
  186.        RETURN
  187.       ENDIF
  188.  320  CONTINUE
  189.  325  CONTINUE
  190. *  VERIFICATION DES DISTANCES AVEC LES AUTRES ARETES RENTRANTES
  191. *  RECHERCHE SI ARETE EXISTE DEJA
  192.       DO 500 I=1,40
  193.       IF=NPF(I,IP)
  194.       IF (IF.EQ.0) GOTO 501
  195.       DO 502 J=1,40
  196.       JF=NPF(J,JP)
  197.       IF (JF.EQ.0) GOTO 500
  198.       IF (IF.EQ.JF) GOTO 800
  199.  502  CONTINUE
  200.  500  CONTINUE
  201.  501  CONTINUE
  202.       XP1=XYZ(1,IP)
  203.       YP1=XYZ(2,IP)
  204.       ZP1=XYZ(3,IP)
  205.       XP2=XYZ(1,JP)
  206.       YP2=XYZ(2,JP)
  207.       ZP2=XYZ(3,JP)
  208.       DP=(XP1-XP2)**2+(YP1-YP2)**2+(ZP1-ZP2)**2
  209.       XP3=(XP1+XP2)/2.d0
  210.       YP3=(YP1+YP2)/2.d0
  211.       ZP3=(ZP1+ZP2)/2.d0
  212. *  TEST AVEC LES AUTRES ARETES POSSIBLES
  213.       goto 800
  214.       do 520 ipt=ip,jp,jp-ip
  215.       DO 510 I=1,40
  216.       IF=NPF(I,IPT)
  217.       if (IF.EQ.0) goto 520
  218.       kp=isucc(if,ipt)
  219.        IF (IP.EQ.KP) GOTO 510
  220.        IF (JP.EQ.KP) GOTO 510
  221.       do 511 J=1,40
  222.       jf=npf(j,kp)
  223.       if (jF.EQ.0) goto 510
  224.       lp=isucc(jf,kp)
  225.        IF (IP.EQ.LP) GOTO 511
  226.        IF (JP.EQ.LP) GOTO 511
  227.       XQ1=XYZ(1,KP)
  228.       YQ1=XYZ(2,KP)
  229.       ZQ1=XYZ(3,KP)
  230.       XQ2=XYZ(1,LP)
  231.       YQ2=XYZ(2,LP)
  232.       ZQ2=XYZ(3,LP)
  233.       DQ=(XQ1-XQ2)**2+(YQ1-YQ2)**2+(ZQ1-ZQ2)**2
  234.       XQ3=(XQ1+XQ2)/2.d0
  235.       YQ3=(YQ1+YQ2)/2.d0
  236.       ZQ3=(ZQ1+ZQ2)/2.d0
  237.       dmin=min(dp,dq)/64d0
  238. *      DT=(XP1-XQ1)**2+(YP1-YQ1)**2+(ZP1-ZQ1)**2
  239. *      IF (DT.LE.dmin) GOTO 810
  240. *      DT=(XP1-XQ2)**2+(YP1-YQ2)**2+(ZP1-ZQ2)**2
  241. *      IF (DT.LE.dmin) GOTO 810
  242. *      DT=(XP1-XQ3)**2+(YP1-YQ3)**2+(ZP1-ZQ3)**2
  243. *      IF (DT.LE.dmin) GOTO 810
  244. *      DT=(XP2-XQ1)**2+(YP2-YQ1)**2+(ZP2-ZQ1)**2
  245. *      IF (DT.LE.dmin) GOTO 810
  246. *      DT=(XP2-XQ2)**2+(YP2-YQ2)**2+(ZP2-ZQ2)**2
  247. *      IF (DT.LE.dmin) GOTO 810
  248. *      DT=(XP2-XQ3)**2+(YP2-YQ3)**2+(ZP2-ZQ3)**2
  249. *      IF (DT.LE.dmin) GOTO 810
  250.       DT=(XP3-XQ1)**2+(YP3-YQ1)**2+(ZP3-ZQ1)**2
  251.       IF (DT.LE.dmin) GOTO 810
  252.       DT=(XP3-XQ2)**2+(YP3-YQ2)**2+(ZP3-ZQ2)**2
  253.       IF (DT.LE.dmin) GOTO 810
  254.       DT=(XP3-XQ3)**2+(YP3-YQ3)**2+(ZP3-ZQ3)**2
  255.       IF (DT.LE.dmin) GOTO 810
  256.  511  continue
  257.  510  CONTINUE
  258.  520  CONTINUE
  259.  800  CONTINUE
  260.       DIAGO=.FALSE.
  261.       RETURN
  262.  810  CONTINUE
  263.       DIAGO=.TRUE.
  264.       IFDIAG=JF
  265.       if (iimpi.ne.0)
  266.      >WRITE (6,*) ' ARETE TROP PROCHES ',IP,JP,KP,LP,dt,dmin
  267. *     WRITE (6,*) 'xp1,yp1,zp1 ',xp1,yp1,zp1
  268. *     WRITE (6,*) 'xp2,yp2,zp2 ',xp2,yp2,zp2
  269. *     WRITE (6,*) 'xp3,yp3,zp3 ',xp3,yp3,zp3
  270. *     WRITE (6,*) 'xq1,yq1,zq1 ',xq1,yq1,zq1
  271. *     WRITE (6,*) 'xq2,yq2,zq2 ',xq2,yq2,zq2
  272. *     WRITE (6,*) 'xq3,yq3,zq3 ',xq3,yq3,zq3
  273.       RETURN
  274.       END
  275.  
  276.  
  277.  
  278.  
  279.  

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