Télécharger arc.eso

Retour à la liste

Numérotation des lignes :

  1. C ARC SOURCE PV 20/04/01 21:15:12 10569
  2. C 1234567890124567890124567898012456789012345678901234567890123456
  3.  
  4. C SOURCE L. DI VALENTIN 20/06/97
  5.  
  6. SUBROUTINE ARC(POINT,CENTRE,NORMAL,ANGLE,INBR,
  7. & DEN1OX,DEN2OX,POINT2)
  8.  
  9.  
  10. C Cette routine, appele par prtran.eso, est chargee de construire
  11. C un arc de cercle en accord avec les elements utilises, de centre
  12. C CENTRE, de normale NORMAL, d'extremites POINT et POINT2 et
  13. C d'angle ANGLE.
  14. C Il y a une redondance entre ces 3 derniers parametres. En fait,
  15. C l'ANGLE est prioritaire devant POINT2 a moins que POINT2 = POINT
  16. C (cf plus loin). La procedure suppose que POINT2 est la 2eme
  17. C extremite de l'arc de cercle. Il est donc important que POINT2
  18. C reference ce point geometrique.
  19.  
  20. C INBR est le nombre de decoupage de l'arc de cercle.
  21. C Si INBR = 0, les densites DEN1OX et DEN2OX sont prises en
  22. C compte pour la decoupe.
  23. C
  24. C Si POINT2 = POINT alors quelque soit l'angle, la subroutine
  25. C construira un cercle. Dans ce cas, ANGLE sera change egal a
  26. C 2*pi (=(2.D0*XPI))
  27. C
  28. C Le maillage resultant est sauve dans la pile a la fin.
  29.  
  30.  
  31. IMPLICIT INTEGER(I-N)
  32. IMPLICIT REAL*8 (A-H,O-Z)
  33. -INC CCREEL
  34. -INC CCOPTIO
  35. -INC CCGEOME
  36. -INC SMELEME
  37. -INC SMCOORD
  38.  
  39.  
  40. SEGMENT TABPAR(NBELEM)
  41.  
  42. INTEGER POINT,CENTRE,NORMAL,INBR,POINT2
  43. REAL*8 ALPHA,ANGLE,DEN1,DEN2
  44.  
  45.  
  46. DEN1 = DEN1OX
  47. DEN2 = DEN2OX
  48.  
  49. C Vecteur Normal :
  50.  
  51. IF (IDIM.EQ.3) THEN
  52. Xn = XCOOR((NORMAL-1)*(IDIM+1) + 1)
  53. Yn = XCOOR((NORMAL-1)*(IDIM+1) + 2)
  54. Zn = XCOOR((NORMAL-1)*(IDIM+1) + 3)
  55.  
  56. ALPHA = SQRT(Xn*Xn+Yn*Yn+Zn*Zn)
  57. IF(ALPHA.LT.XPETIT) ALPHA = 1.D0
  58. Xn = Xn / ALPHA
  59. Yn = Yn / ALPHA
  60. Zn = Zn / ALPHA
  61.  
  62. ELSE
  63. Xn = 0.D0
  64. Yn = 0.D0
  65. Zn = 1.D0
  66.  
  67. ENDIF
  68.  
  69.  
  70. C On recupere les coordonnees du CENTRE
  71.  
  72. XCEN = XCOOR((CENTRE-1)*(IDIM+1) + 1)
  73. YCEN = XCOOR((CENTRE-1)*(IDIM+1) + 2)
  74. IF (IDIM.EQ.3) THEN
  75. ZCEN = XCOOR((CENTRE-1)*(IDIM+1) + 3)
  76. ENDIF
  77.  
  78. C On recupere les coordonnees du vecteur (CENTRE -> POINT)
  79.  
  80. X1 = XCOOR((POINT-1)*(IDIM+1) + 1) - XCEN
  81. Y1 = XCOOR((POINT-1)*(IDIM+1) + 2) - YCEN
  82.  
  83. IF (IDIM.EQ.3) THEN
  84. Z1 = XCOOR((POINT-1)*(IDIM+1) + 3) - ZCEN
  85. ELSE
  86. Z1 = 0.D0
  87. ENDIF
  88.  
  89. RAYON = SQRT(X1*X1+Y1*Y1+Z1*Z1)
  90.  
  91.  
  92. C On calcule le vecteur definissant avec le vecteur precedent
  93. C le 2eme vecteur de la base du cercle
  94.  
  95. X2 = Z1*Yn - Y1*Zn
  96. Y2 = X1*Zn - Z1*Xn
  97. Z2 = Y1*Xn - X1*Yn
  98.  
  99.  
  100. C Cas du cercle :
  101.  
  102. IF (POINT.EQ.POINT2) THEN
  103. ANGLE = (2.D0*XPI)
  104. ENDIF
  105.  
  106.  
  107. DLONG = ABS(ANGLE * RAYON)
  108. IF(DLONG.LT.XPETIT) DLONG = 1.D0
  109. C DEN1 = 1.D0/INBR
  110. DEN1 = DEN1/DLONG
  111. DEN2 = DEN2/DLONG
  112.  
  113. CALL DECOUP(INBR,DEN1,DEN2,APROG,NBELEM,DENI,DECA,DLONG)
  114. DLONG = ANGLE * RAYON
  115.  
  116. C NBELEM = INBR
  117. NX = NBELEM - 1
  118.  
  119. NBSOUS=0
  120. NBREF=0
  121. IF (ILCOUR.EQ.0) GOTO 666
  122. IF (KDEGRE(ILCOUR).EQ.0) GOTO 666
  123. NBNN=NBNNE(KDEGRE(ILCOUR))
  124. IF (NBNN.EQ.0) GOTO 666
  125.  
  126.  
  127. SEGINI MELEME
  128. SEGINI TABPAR
  129.  
  130. ITYPEL = KDEGRE(ILCOUR)
  131.  
  132. DIN = DEN1
  133.  
  134. IPOO = nbpts
  135. NUM(1,1) = POINT
  136.  
  137.  
  138. IF (NX.EQ.0) GOTO 110
  139.  
  140. DO 102 I=1,NX
  141. DIN = DIN * APROG
  142. IF (ITYPEL.EQ.2) GOTO 103
  143. IPOO=IPOO+1
  144. NUM(2,I)=IPOO
  145. NUM(3,I)=IPOO+1
  146. 103 IPOO=IPOO+1
  147. TABPAR(I) = DIN
  148. NUM(1,I+1)=IPOO
  149. IF (ITYPEL.EQ.3) GOTO 102
  150. NUM(2,I)=IPOO
  151.  
  152. 102 CONTINUE
  153.  
  154.  
  155. 110 DIN = DIN * APROG
  156. IF (ITYPEL.NE.3) GOTO 115
  157. IPOO=IPOO+1
  158. NUM(2,NBELEM)=IPOO
  159. TABPAR(NBELEM) = DIN
  160. 115 CONTINUE
  161.  
  162.  
  163. NUM(ITYPEL,NBELEM)=POINT2
  164.  
  165. SEGACT MCOORD*mod
  166. IADR=NBPTS
  167.  
  168.  
  169. C Creation des points
  170.  
  171. DPAR=0
  172.  
  173. IF (NX.EQ.0) GOTO 300
  174. NBPTS=IADR+NX*(ITYPEL-1)
  175.  
  176.  
  177. SEGADJ MCOORD
  178.  
  179. DO 301 I=1,NX
  180.  
  181. DIN = TABPAR(I)
  182. DPAR=DPAR+DIN
  183. IF (ITYPEL.EQ.2) GOTO 1103
  184. DPAR1=DPAR-DIN*0.5D0
  185.  
  186. PARA=ANGLE*DPAR1
  187. COSA=COS(PARA)
  188. SINA=SIN(PARA)
  189.  
  190. XCOOR(IADR*(IDIM+1)+1)=XCEN+COSA*X1+SINA*X2
  191. XCOOR(IADR*(IDIM+1)+2)=YCEN+COSA*Y1+SINA*Y2
  192. IF (IDIM.EQ.3) THEN
  193. XCOOR(IADR*(IDIM+1)+3)=ZCEN+COSA*Z1+SINA*Z2
  194. ENDIF
  195.  
  196. XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR1
  197. IADR=IADR+1
  198.  
  199. 1103 PARA=ANGLE*DPAR
  200. COSA=COS(PARA)
  201. SINA=SIN(PARA)
  202.  
  203. XCOOR(IADR*(IDIM+1)+1)=XCEN+COSA*X1+SINA*X2
  204. XCOOR(IADR*(IDIM+1)+2)=YCEN+COSA*Y1+SINA*Y2
  205. IF (IDIM.EQ.3) THEN
  206. XCOOR(IADR*(IDIM+1)+3)=ZCEN+COSA*Z1+SINA*Z2
  207. ENDIF
  208.  
  209. XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR
  210. IADR=IADR+1
  211.  
  212. 301 CONTINUE
  213.  
  214. NBPTS = IADR
  215.  
  216.  
  217. SEGADJ MCOORD
  218.  
  219.  
  220. 300 DIN = TABPAR(NBELEM)
  221. DPAR=DPAR+DIN
  222.  
  223. IF (ITYPEL.NE.3) GOTO 303
  224.  
  225. NBPTS = IADR+1
  226. SEGADJ MCOORD
  227. DPAR1 = DPAR-DIN*0.5D0
  228.  
  229. PARA = ANGLE * DPAR1
  230. COSA = COS(PARA)
  231. SINA = SIN(PARA)
  232.  
  233. XCOOR(IADR*(IDIM+1)+1) = XCEN + X1*COSA + X2*SINA
  234. XCOOR(IADR*(IDIM+1)+2) = YCEN + Y1*COSA + Y2*SINA
  235. IF (IDIM.EQ.3) THEN
  236. XCOOR(IADR*(IDIM+1)+3) = ZCEN + Z1*COSA + Z2*SINA
  237. ENDIF
  238.  
  239. XCOOR((IADR+1)*(IDIM+1)) = DENI+DECA*DPAR1
  240. IADR=IADR + 1
  241.  
  242.  
  243. 303 DO 309 I=1,NUM(/2)
  244. ICOLOR(I)=IDCOUL
  245. 309 CONTINUE
  246. SEGSUP TABPAR
  247. SEGDES MELEME
  248.  
  249. CALL ECROBJ('MAILLAGE',MELEME)
  250. RETURN
  251. * Erreur 16 Type d'element incorrect
  252. 666 CONTINUE
  253. CALL ERREUR(16)
  254. RETURN
  255. END
  256.  
  257.  
  258.  
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  

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