Télécharger la plaquette Cast3M


fr en

Télécharger facet.eso

Retour à la liste

Numérotation des lignes : 

facet

  1. C FACET     SOURCE    JC220346  16/11/29    21:15:14     9221           
  2. C---------------------------------------------------------------------|
  3. C                                                                     |
  4.        LOGICAL FUNCTION FACET(JF)
  5. C                                                                     |
  6. C      CETTE FONCTION LOGIQUE INDIQUE SI LA FACETTE JF EST VALIDE.    |
  7. C      -0- On verifie que les diag des quadr ne sont pas des aretes   !
  8. C      -1- ON TESTE LES ANGLES DES SEGMENTS DE LA FACETTES            |
  9. C      SI CES ANGLES SONT TROP PETITS, LA FACETTE EST INVALIDE |      |
  10. C      -2- ON TESTE LES ANGLES DE LA FACETTE JF AVEC LES FACETES      |
  11. C      ADJACENTES: SI CET ANGLE EST TROP PETIT, LA FACETTE EST        |
  12. C      INVALIDE |                                                     |
  13. C      -3- ON TESTE L'INTERSECTION DE LA FACETTE AVEC LES FACETTES    |
  14. C      ENVIRONNANTES.                                                 |
  15. C      -4- ON VERIFIE LA POSITION DES ARETES DE LA FACETTE PAR        |
  16. C      AUX FACETTES AVOISINANTES                                      |
  17. C                                                                     |
  18. C---------------------------------------------------------------------|
  19. C
  20.       IMPLICIT INTEGER(I-N)
  21.       IMPLICIT REAL*8(A-H,O-Z)
  22. -INC TDEMAIT
  23.  
  24. -INC PPARAM
  25. -INC CCOPTIO
  26.        LOGICAL REPONS,INTER,DROIT,FACET2,ARET,TSDIS,icause
  27. C  SI LA FACETTE A ETE SUPPRIME ELLE EST CONSIDEREE COMME BONNE
  28.         ifs=jf
  29.         icause=.false.
  30.         iirfac=0
  31.         j1rfac=0
  32.         j2rfac=0
  33.         ifrfac=0
  34.         DO 10 I=1,NFACET
  35.              IF (IFUT(I).EQ.JF) GOTO 20
  36.   10    CONTINUE
  37.         FACET=.TRUE.
  38.         RETURN
  39.   20    CONTINUE
  40. C
  41.        FACET=.FALSE.
  42. C
  43.        I1=NFC(1,JF)
  44.        I2=NFC(2,JF)
  45.        I3=NFC(3,JF)
  46.        I4=NFC(4,JF)
  47. C
  48. C      0EME CAS
  49. C      --------
  50.        if (i4.ne.0) then
  51.        DO 100 I=1,40
  52.           IF=NPF(I,I1)
  53.           if (if.eq.jf) goto 100
  54.               IF (IF.EQ.0) GOTO 120
  55.               DO 110 J=1,40
  56.                      IF (NPF(J,i3).EQ.0) GOTO 100
  57.                      IF (IF.eq.NPF(J,i3)) GOTO 150
  58.  110          continue
  59.  100   continue
  60.  120   continue
  61.        DO 130 I=1,40
  62.           IF=NPF(I,I2)
  63.           if (if.eq.jf) goto 130
  64.               IF (IF.EQ.0) GOTO 160
  65.               DO 140 J=1,40
  66.                      IF (NPF(J,i4).EQ.0) GOTO 130
  67.                      IF (IF.eq.NPF(J,i4)) GOTO 150
  68.  140          continue
  69.  130   continue
  70.        goto 160
  71.  150   continue
  72. *      write (6,*) ' facet diagonale arete'
  73.        return
  74.  160   continue
  75.        endif
  76. C
  77. C      1ER CAS
  78. C      --------
  79.         IF (.NOT.DROIT(I1,I2,I3)) RETURN
  80.        IF (I4.NE.0) THEN
  81.         IF (.NOT.DROIT(I2,I3,I4)) RETURN
  82.         IF (.NOT.DROIT(I3,I4,I1)) RETURN
  83.         IF (.NOT.DROIT(I4,I1,I2)) RETURN
  84.        ELSE
  85.         IF (.NOT.DROIT(I2,I3,I1)) RETURN
  86.         IF (.NOT.DROIT(I3,I1,I2)) RETURN
  87.        ENDIF
  88. C
  89. C      2EME CAS:
  90. C      --------
  91. C
  92.        ANG=TETA(JF,NOISIN(I1,I2,JF),I1,I2)
  93.        IF (ANG.GT.CFACET.or.ang.lt.-2000000-cfacet) then
  94.          icause=.true.
  95.          kf=NOISIN(I1,I2,JF)
  96.          ifrfac=ifs
  97.          iirfac=nfc(1,kf)
  98.          j1rfac=nfc(2,kf)
  99.          j2rfac=nfc(3,kf)
  100. *        write (6,*) ' facet angle 1 incorrect ',ang
  101.          RETURN
  102.        ENDIF
  103. C
  104.        ANG=TETA(JF,NOISIN(I2,I3,JF),I2,I3)
  105.        IF (ANG.GT.CFACET.or.ang.lt.-2000000-cfacet) then
  106.          icause=.true.
  107.          kf=NOISIN(I2,I3,JF)
  108.          ifrfac=ifs
  109.          iirfac=nfc(1,kf)
  110.          j1rfac=nfc(2,kf)
  111.          j2rfac=nfc(3,kf)
  112. *        write (6,*) ' facet angle 2 incorrect ',ang
  113.          RETURN
  114.        ENDIF
  115. C
  116.       IF (I4.EQ.0) THEN
  117.        ANG=TETA(JF,NOISIN(I3,I1,JF),I3,I1)
  118.        IF (ANG.GT.CFACET.or.ang.lt.-2000000-cfacet) then
  119.          icause=.true.
  120.          kf=NOISIN(I3,I1,JF)
  121.          ifrfac=ifs
  122.          iirfac=nfc(1,kf)
  123.          j1rfac=nfc(2,kf)
  124.          j2rfac=nfc(3,kf)
  125. *        write (6,*) ' facet angle 3 incorrect ',ang
  126.          RETURN
  127.        ENDIF
  128.       ELSE
  129.        ANG=TETA(JF,NOISIN(I3,I4,JF),I3,I4)
  130.        IF (ANG.GT.CFACET.or.ang.lt.-2000000-cfacet) then
  131.          icause=.true.
  132.          kf=NOISIN(I3,I4,JF)
  133.          ifrfac=ifs
  134.          iirfac=nfc(1,kf)
  135.          j1rfac=nfc(2,kf)
  136.          j2rfac=nfc(3,kf)
  137. *        write (6,*) ' facet angle 4 incorrect ',ang
  138.          RETURN
  139.        ENDIF
  140. C
  141.        ANG=TETA(JF,NOISIN(I4,I1,JF),I4,I1)
  142.        IF (ANG.GT.CFACET.or.ang.lt.-2000000-cfacet) then
  143.          icause=.true.
  144.          kf=NOISIN(I4,I1,JF)
  145.          ifrfac=ifs
  146.          iirfac=nfc(1,kf)
  147.          j1rfac=nfc(2,kf)
  148.          j2rfac=nfc(3,kf)
  149. *        write (6,*) ' facet angle 5 incorrect ',ang
  150.          RETURN
  151.        ENDIF
  152.       ENDIF
  153. C
  154. C      3EME CAS:
  155. C      ---------
  156.        FACET=.TRUE.
  157. C
  158. C      TEST DE L'INTERSECTION DE LA FACETTE JF AVEC LES FACETTES ENVIRON
  159. C      -----------------------------------------------------------------
  160. C         ( AYANT UN POINT COMMUN AVEC LA FACETTE TESTEE )
  161. C      EGALEMENT TEST DES POSITIONS RELATIVES
  162. C      --------------------------------------
  163. C
  164.       NBD=4
  165.       IF (NFC(4,JF).EQ.0) NBD=3
  166.       IPROB=0
  167.       DO 200 IP=1,NBD
  168. *  POINT DE LA FACE
  169.       II=NFC(IP,JF)
  170.       I1=IPRED(JF,II)
  171.       I2=ISUCC(JF,II)
  172.       dref= (xyz(1,i2)-xyz(1,i1))**2
  173.      >    + (xyz(2,i2)-xyz(2,i1))**2
  174.      >    + (xyz(3,i2)-xyz(3,i1))**2
  175. *  TEST DE SITUATION A EVITER SI 4 FACES AUTOUR DU POINT
  176.       DO 210 I=1,40
  177. *  FACE CONTENANT LE POINT
  178.        KF=NPF(I,II)
  179.        IF (KF.EQ.0) GOTO 200
  180.        IF (KF.EQ.JF) GOTO 210
  181.        J1=IPRED(KF,II)
  182.        J2=ISUCC(KF,II)
  183.        IF (I1.EQ.J1) GOTO 210
  184.        IF (I1.EQ.J2) GOTO 210
  185.        IF (I2.EQ.J1) GOTO 210
  186.        IF (I2.EQ.J2) GOTO 210
  187. *  Y A T IL INTERSECTION ??? LES DEUX POINTS D'UNE FACE SONT DE PART ET
  188. *  D'AUTRE DE L'AUTRE
  189.        V1=VOL(I1,II,J1,J2)
  190.        V2=VOL(I2,II,J1,J2)
  191.        av1=abs(v1)
  192.        av2=abs(v2)
  193.        VV=max(av1,av2)/faccri
  194. *pv     IF (V1*V2.GE.0.d0) GOTO 210
  195.         IF (av1.gt.vv.and.av2.gt.vv.and.V1*V2.GT.1D-12*dref**3) GOTO 210
  196.        W1=VOL(J1,II,I1,I2)
  197.        W2=VOL(J2,II,I1,I2)
  198.        aw1=abs(w1)
  199.        aw2=abs(w2)
  200.        ww=max(aw1,aw2)/faccri
  201. *pv     IF (W1*W2.GE.0.d0) GOTO 210
  202.         IF (aw1.gt.ww.and.aw2.gt.ww.and.W1*W2.GT.1D-12*dref**3) GOTO 210
  203. *  si les deux facettes sont à peu pres coplanaires, test spécial
  204.         if (max(av1,av2,aw1,aw2).lt.1e-6*dref**(3/2)) then
  205. *       write (6,*) ' FACET facettes coplanaires '
  206. *  si il y a intersection i1 ou i2 est entre j1 et j2  ou l'inverse
  207.         xi1=xyz(1,i1)-xyz(1,ii)
  208.         yi1=xyz(2,i1)-xyz(2,ii)
  209.         zi1=xyz(3,i1)-xyz(3,ii)
  210.         si1=sqrt(xi1**2+yi1**2+zi1**2)
  211.         xi2=xyz(1,i2)-xyz(1,ii)
  212.         yi2=xyz(2,i2)-xyz(2,ii)
  213.         zi2=xyz(3,i2)-xyz(3,ii)
  214.         si2=sqrt(xi2**2+yi2**2+zi2**2)
  215.         xj1=xyz(1,j1)-xyz(1,ii)
  216.         yj1=xyz(2,j1)-xyz(2,ii)
  217.         zj1=xyz(3,j1)-xyz(3,ii)
  218.         sj1=sqrt(xj1**2+yj1**2+zj1**2)
  219.         xj2=xyz(1,j2)-xyz(1,ii)
  220.         yj2=xyz(2,j2)-xyz(2,ii)
  221.         zj2=xyz(3,j2)-xyz(3,ii)
  222.         sj2=sqrt(xj2**2+yj2**2+zj2**2)
  223.         xn1=yi1*zj1-zi1*yj1
  224.         yn1=zi1*xj1-xi1*zj1
  225.         zn1=xi1*yj1-yi1*xj1
  226.         xn2=yi1*zj2-zi1*yj2
  227.         yn2=zi1*xj2-xi1*zj2
  228.         zn2=xi1*yj2-yi1*xj2
  229.         sc1=xn1*xn2+yn1*yn2+zn1*zn2
  230.         sd1=xi1*(xj1/sj1+xj2/sj2)+yi1*(yj1/sj1+yj2/sj2)
  231.      >                           +zi1*(zj1/sj1+zj2/sj2)
  232.         xn1=yi2*zj1-zi2*yj1
  233.         yn1=zi2*xj1-xi2*zj1
  234.         zn1=xi2*yj1-yi2*xj1
  235.         xn2=yi2*zj2-zi2*yj2
  236.         yn2=zi2*xj2-xi2*zj2
  237.         zn2=xi2*yj2-yi2*xj2
  238.         sc2=xn1*xn2+yn1*yn2+zn1*zn2
  239.         sd2=xi2*(xj1/sj1+xj2/sj2)+yi2*(yj1/sj1+yj2/sj2)
  240.      >                           +zi2*(zj1/sj1+zj2/sj2)
  241.         if ((sc1.lt.0.D0.and.sd1.gt.0.d0).or.
  242.      >      (sc2.lt.0.D0.and.sd2.gt.0.d0)) then
  243. *        WRITE (6,*) ' FACET TRIANGLES COPLANAIRES INTERSECTANTS '
  244. *        WRITE (6,*) II,I1,I2,II,J1,J2,v1,v2,w1,w2,sc1,sc2
  245.          FACET=.FALSE.
  246.          icause=.true.
  247.          ifrfac=ifs
  248.          iirfac=ii
  249.          j1rfac=j1
  250.          j2rfac=j2
  251.          RETURN
  252.         endif
  253.         goto 210
  254.         endif
  255. *  VERIFIER QUE II (I1 I2 INTER F2 ) ET II (J1 J2 INTER F1) SONT
  256. *  DANS LA MEME DIRECTION
  257.        if ((v2-v1).eq.0.d0) goto 210
  258.        XN1=(V2*XYZ(1,I1)-V1*XYZ(1,I2))/(V2-V1)-XYZ(1,II)
  259.        YN1=(V2*XYZ(2,I1)-V1*XYZ(2,I2))/(V2-V1)-XYZ(2,II)
  260.        ZN1=(V2*XYZ(3,I1)-V1*XYZ(3,I2))/(V2-V1)-XYZ(3,II)
  261.        if ((w2-w1).eq.0.d0) goto 210
  262.        XN2=(W2*XYZ(1,J1)-W1*XYZ(1,J2))/(W2-W1)-XYZ(1,II)
  263.        YN2=(W2*XYZ(2,J1)-W1*XYZ(2,J2))/(W2-W1)-XYZ(2,II)
  264.        ZN2=(W2*XYZ(3,J1)-W1*XYZ(3,J2))/(W2-W1)-XYZ(3,II)
  265.        IF (XN1*XN2+YN1*YN2+ZN1*ZN2.LT.0.D0) GOTO 210
  266. *       WRITE (6,*) ' FACET TRIANGLES INTERSECTANTS '
  267. *       WRITE (6,*) II,I1,I2,II,J1,J2,v1,v2,w1,w2
  268. *       WRITE (6,*) XN1*XN2+YN1*YN2+ZN1*ZN2
  269. *       WRITE (6,*) 'dref ',dref
  270. *       write (6,*) 'ii ',xyz(1,ii),xyz(2,ii),xyz(3,ii)
  271. *       write (6,*) 'i1 ',xyz(1,i1),xyz(2,i1),xyz(3,i1)
  272. *       write (6,*) 'i2 ',xyz(1,i2),xyz(2,i2),xyz(3,i2)
  273. *       write (6,*) 'j1 ',xyz(1,j1),xyz(2,j1),xyz(3,j1)
  274. *       write (6,*) 'j2 ',xyz(1,j2),xyz(2,j2),xyz(3,j2)
  275.         FACET=.FALSE.
  276.         icause=.true.
  277.          ifrfac=ifs
  278.          iirfac=ii
  279.          j1rfac=j1
  280.          j2rfac=j2
  281.         RETURN
  282.  210  CONTINUE
  283.  200  CONTINUE
  284.       if (.not.facet) return
  285. C
  286. C  TEST DE LA POSITION DES ARETES PAR AUX FACETTES VOISINES
  287. C
  288. *      FACET=ARET(I1,I2)
  289. *      IF (.NOT.FACET) RETURN
  290. *      FACET=ARET(I2,I3)
  291. *      IF (.NOT.FACET) RETURN
  292. *      IF (I4.EQ.0) THEN
  293. *        FACET=ARET(I3,I1)
  294. *        IF (.NOT.FACET) RETURN
  295. *      ELSE
  296. *        FACET=ARET(I3,I4)
  297. *        IF (.NOT.FACET) RETURN
  298. *        FACET=ARET(I4,I1)
  299. *        IF (.NOT.FACET) RETURN
  300. *      ENDIF
  301.        RETURN
  302. *  test de la position des points existants par rapport a la facette
  303. C
  304. C
  305. C      FACET=FALSE SI LA NOUVELLE FACETTE EST MAUVAISE
  306. C      FACET=TRUE SI LA NOUVELLE FACETTE EST BONNE
  307. C
  308.        END
  309.  
  310.  
  311.  
  312.  
  313.  

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