Télécharger arc.eso

Retour à la liste

Numérotation des lignes :

  1. C ARC SOURCE BP208322 16/11/18 21:15:11 9177
  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. NBPTS = XCOOR(/1)/(IDIM + 1)
  108. DLONG = ABS(ANGLE * RAYON)
  109. IF(DLONG.LT.XPETIT) DLONG = 1.D0
  110. C DEN1 = 1.D0/INBR
  111. DEN1 = DEN1/DLONG
  112. DEN2 = DEN2/DLONG
  113.  
  114. CALL DECOUP(INBR,DEN1,DEN2,APROG,NBELEM,DENI,DECA,DLONG)
  115. DLONG = ANGLE * RAYON
  116.  
  117. C NBELEM = INBR
  118. NX = NBELEM - 1
  119.  
  120. NBSOUS=0
  121. NBREF=0
  122. IF (ILCOUR.EQ.0) GOTO 666
  123. IF (KDEGRE(ILCOUR).EQ.0) GOTO 666
  124. NBNN=NBNNE(KDEGRE(ILCOUR))
  125. IF (NBNN.EQ.0) GOTO 666
  126.  
  127.  
  128. SEGINI MELEME
  129. SEGINI TABPAR
  130.  
  131. ITYPEL = KDEGRE(ILCOUR)
  132.  
  133. DIN = DEN1
  134.  
  135. IPOO = XCOOR(/1)/(IDIM + 1 )
  136. NUM(1,1) = POINT
  137.  
  138.  
  139. IF (NX.EQ.0) GOTO 110
  140.  
  141. DO 102 I=1,NX
  142. DIN = DIN * APROG
  143. IF (ITYPEL.EQ.2) GOTO 103
  144. IPOO=IPOO+1
  145. NUM(2,I)=IPOO
  146. NUM(3,I)=IPOO+1
  147. 103 IPOO=IPOO+1
  148. TABPAR(I) = DIN
  149. NUM(1,I+1)=IPOO
  150. IF (ITYPEL.EQ.3) GOTO 102
  151. NUM(2,I)=IPOO
  152.  
  153. 102 CONTINUE
  154.  
  155.  
  156. 110 DIN = DIN * APROG
  157. IF (ITYPEL.NE.3) GOTO 115
  158. IPOO=IPOO+1
  159. NUM(2,NBELEM)=IPOO
  160. TABPAR(NBELEM) = DIN
  161. 115 CONTINUE
  162.  
  163.  
  164. NUM(ITYPEL,NBELEM)=POINT2
  165.  
  166. IADR=XCOOR(/1)/(IDIM+1)
  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.  

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