Télécharger la plaquette Cast3M


fr en

Télécharger j3aret.eso

Retour à la liste

Numérotation des lignes : 

j3aret

  1. C J3ARET    SOURCE    CHAT      05/01/13    00:45:53     5004
  2.       SUBROUTINE J3ARET(BLOCOM,TOL)
  3. C--------------------------------------------------------------------
  4. C
  5. C     ADDITION DES POINTS SUR LES ARRETES
  6. C
  7. C     PP /9/97
  8. C     Pierre Pegon/JRC Ispra
  9. C--------------------------------------------------------------------
  10.       IMPLICIT INTEGER(I-N)
  11.       IMPLICIT REAL*8 (A-H,O-Z)
  12. C
  13.  
  14. -INC PPARAM
  15. -INC CCOPTIO
  16. -INC SMELEME
  17. C
  18.       SEGMENT BLOCOM
  19.         INTEGER POINT(NPOINT)
  20.         REAL*8 YCOOR(IDIM+1,NPOINT)
  21.         INTEGER MAILL(MM1)
  22.       ENDSEGMENT
  23. C
  24.       DIMENSION V1(3),V2(3),VI(3)
  25. C
  26.       IF(IDIM.EQ.2)THEN
  27.         V1(3)=0.D0
  28.         V2(3)=0.D0
  29.         VI(3)=0.D0
  30.       ENDIF
  31. C
  32.       MM1=MAILL(/1)
  33.       NPOINT=POINT(/1)
  34.       TOL2=TOL**2
  35. C
  36. C     ON BOUCLE SUR TOUS LES CONTOURS
  37. C
  38.       NBSOUS=0
  39.       NBREF=0
  40.       NBNN=2
  41.       DO IE1=1,MM1
  42.         MELEME=MAILL(IE1)
  43.         NBELEM=ICOLOR(/1)
  44. C
  45. C     ... ET SUR TOUS LEURS COTES
  46. C     (ON SIMULE "DO 3 IE2=1,NBELEM" AVEC IE2 ET NBELEM EVENTUELLEMENT CHANGES)
  47. C
  48.         IE2=0
  49.  1      IE2=IE2+1
  50.         IF(IE2.GT.NBELEM)GOTO 3
  51. C       DO IE2=1,NBELEM
  52.           D12=0.D0
  53.           DO IE3=1,IDIM
  54.             V1(IE3)=YCOOR(IE3,NUM(1,IE2))
  55.             V2(IE3)=YCOOR(IE3,NUM(2,IE2))
  56.             D12=D12+(V1(IE3)-V2(IE3))**2
  57.           ENDDO
  58. C
  59. C     ON BOUCLE SUR TOUS LES POINTS ...
  60. C
  61.           DO 2 IE3=1,NPOINT
  62.             DI1=0.D0
  63.             DI2=0.D0
  64.             DO IE4=1,IDIM
  65.               VI(IE4)=YCOOR(IE4,POINT(IE3))
  66.               DI1=DI1+(VI(IE4)-V1(IE4))**2
  67.               DI2=DI2+(VI(IE4)-V2(IE4))**2
  68.             ENDDO
  69. C
  70. C     ... ON ELIMINE CEUX QUI SONT TROP LOIN ...
  71. C
  72.             IF((DI1.GT.D12+TOL2).OR.(DI2.GT.D12+TOL2))GOTO 2
  73. C
  74. C     ... ON ELIMINE CEUX QUI SONT TROP PRES ...
  75. C
  76.             IF((DI1.LT.TOL2).OR.(DI2.LT.TOL2))GOTO 2
  77. C
  78. C     ... CEUX QUI NE SONT PAS ENTRE ...
  79. C
  80.             AAA=0.D0
  81.             DO IE4=1,IDIM
  82.               AAA=AAA+(VI(IE4)-V1(IE4))*(V2(IE4)-V1(IE4))
  83.             ENDDO
  84.             AAA=AAA/D12
  85.             IF(AAA.LT.0.D0.OR.AAA.GT.1.D0)GOTO 2
  86. C
  87. C     ... ET CEUX QUI SONT TROP LOIN DU SEGMENT
  88. C
  89.             BBB=0.D0
  90.             DO IE4=1,IDIM
  91.               BBB=BBB+(VI(IE4)-V1(IE4)-AAA*(V2(IE4)-V1(IE4)))**2
  92.             ENDDO
  93.             IF(BBB.GT.TOL2)GOTO 2
  94. C
  95. C     ON INCERE LES POINT RESTANT DANS LE MAILLAGE
  96. C     WARNING: ON LE FAIT SANS DUPLICATION
  97. C
  98.             NBELEM=NBELEM+1
  99.             SEGADJ, MELEME
  100.             ICOLOR(NBELEM)=ICOLOR(NBELEM-1)
  101.             IF(IE2.LT.NBELEM)THEN
  102.               DO IE4=NBELEM,IE2+1,-1
  103.                 NUM(1,IE4)=NUM(1,IE4-1)
  104.                 NUM(2,IE4)=NUM(2,IE4-1)
  105.               ENDDO
  106.             ENDIF
  107.             NUM(2,IE2  )=POINT(IE3)
  108.             NUM(1,IE2+1)=POINT(IE3)
  109.  
  110. C     ... ET ON REPASSE PAR LE NOUVEAU SEGMENT EN SORTANT DE LA BOUCLE POINT
  111. C
  112.             IE2=IE2-1
  113.             GOTO 1
  114. C
  115. C     FIN BOUCLE POINT
  116. C
  117.  2        CONTINUE
  118. C
  119. C     FIN BOUCLE COTE
  120. C
  121.           GOTO 1
  122.  3      CONTINUE
  123. C
  124. C     FIN BOUCLE FACE
  125. C
  126.       ENDDO
  127. C
  128.       RETURN
  129.       END
  130.  
  131.  
  132.  

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