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.  
  35. -INC PPARAM
  36. -INC CCOPTIO
  37. -INC CCGEOME
  38. -INC SMELEME
  39. -INC SMCOORD
  40.  
  41.  
  42. SEGMENT TABPAR(NBELEM)
  43.  
  44. INTEGER POINT,CENTRE,NORMAL,INBR,POINT2
  45. REAL*8 ALPHA,ANGLE,DEN1,DEN2
  46.  
  47.  
  48. DEN1 = DEN1OX
  49. DEN2 = DEN2OX
  50.  
  51. C Vecteur Normal :
  52.  
  53. IF (IDIM.EQ.3) THEN
  54. Xn = XCOOR((NORMAL-1)*(IDIM+1) + 1)
  55. Yn = XCOOR((NORMAL-1)*(IDIM+1) + 2)
  56. Zn = XCOOR((NORMAL-1)*(IDIM+1) + 3)
  57.  
  58. ALPHA = SQRT(Xn*Xn+Yn*Yn+Zn*Zn)
  59. IF(ALPHA.LT.XPETIT) ALPHA = 1.D0
  60. Xn = Xn / ALPHA
  61. Yn = Yn / ALPHA
  62. Zn = Zn / ALPHA
  63.  
  64. ELSE
  65. Xn = 0.D0
  66. Yn = 0.D0
  67. Zn = 1.D0
  68.  
  69. ENDIF
  70.  
  71.  
  72. C On recupere les coordonnees du CENTRE
  73.  
  74. XCEN = XCOOR((CENTRE-1)*(IDIM+1) + 1)
  75. YCEN = XCOOR((CENTRE-1)*(IDIM+1) + 2)
  76. IF (IDIM.EQ.3) THEN
  77. ZCEN = XCOOR((CENTRE-1)*(IDIM+1) + 3)
  78. ENDIF
  79.  
  80. C On recupere les coordonnees du vecteur (CENTRE -> POINT)
  81.  
  82. X1 = XCOOR((POINT-1)*(IDIM+1) + 1) - XCEN
  83. Y1 = XCOOR((POINT-1)*(IDIM+1) + 2) - YCEN
  84.  
  85. IF (IDIM.EQ.3) THEN
  86. Z1 = XCOOR((POINT-1)*(IDIM+1) + 3) - ZCEN
  87. ELSE
  88. Z1 = 0.D0
  89. ENDIF
  90.  
  91. RAYON = SQRT(X1*X1+Y1*Y1+Z1*Z1)
  92.  
  93.  
  94. C On calcule le vecteur definissant avec le vecteur precedent
  95. C le 2eme vecteur de la base du cercle
  96.  
  97. X2 = Z1*Yn - Y1*Zn
  98. Y2 = X1*Zn - Z1*Xn
  99. Z2 = Y1*Xn - X1*Yn
  100.  
  101.  
  102. C Cas du cercle :
  103.  
  104. IF (POINT.EQ.POINT2) THEN
  105. ANGLE = (2.D0*XPI)
  106. ENDIF
  107.  
  108.  
  109. DLONG = ABS(ANGLE * RAYON)
  110. IF(DLONG.LT.XPETIT) DLONG = 1.D0
  111. C DEN1 = 1.D0/INBR
  112. DEN1 = DEN1/DLONG
  113. DEN2 = DEN2/DLONG
  114.  
  115. CALL DECOUP(INBR,DEN1,DEN2,APROG,NBELEM,DENI,DECA,DLONG)
  116. DLONG = ANGLE * RAYON
  117.  
  118. C NBELEM = INBR
  119. NX = NBELEM - 1
  120.  
  121. NBSOUS=0
  122. NBREF=0
  123. IF (ILCOUR.EQ.0) GOTO 666
  124. IF (KDEGRE(ILCOUR).EQ.0) GOTO 666
  125. NBNN=NBNNE(KDEGRE(ILCOUR))
  126. IF (NBNN.EQ.0) GOTO 666
  127.  
  128.  
  129. SEGINI MELEME
  130. SEGINI TABPAR
  131.  
  132. ITYPEL = KDEGRE(ILCOUR)
  133.  
  134. DIN = DEN1
  135.  
  136. IPOO = nbpts
  137. NUM(1,1) = POINT
  138.  
  139.  
  140. IF (NX.EQ.0) GOTO 110
  141.  
  142. DO 102 I=1,NX
  143. DIN = DIN * APROG
  144. IF (ITYPEL.EQ.2) GOTO 103
  145. IPOO=IPOO+1
  146. NUM(2,I)=IPOO
  147. NUM(3,I)=IPOO+1
  148. 103 IPOO=IPOO+1
  149. TABPAR(I) = DIN
  150. NUM(1,I+1)=IPOO
  151. IF (ITYPEL.EQ.3) GOTO 102
  152. NUM(2,I)=IPOO
  153.  
  154. 102 CONTINUE
  155.  
  156.  
  157. 110 DIN = DIN * APROG
  158. IF (ITYPEL.NE.3) GOTO 115
  159. IPOO=IPOO+1
  160. NUM(2,NBELEM)=IPOO
  161. TABPAR(NBELEM) = DIN
  162. 115 CONTINUE
  163.  
  164.  
  165. NUM(ITYPEL,NBELEM)=POINT2
  166.  
  167. SEGACT MCOORD*mod
  168. IADR=NBPTS
  169.  
  170.  
  171. C Creation des points
  172.  
  173. DPAR=0
  174.  
  175. IF (NX.EQ.0) GOTO 300
  176. NBPTS=IADR+NX*(ITYPEL-1)
  177.  
  178.  
  179. SEGADJ MCOORD
  180.  
  181. DO 301 I=1,NX
  182.  
  183. DIN = TABPAR(I)
  184. DPAR=DPAR+DIN
  185. IF (ITYPEL.EQ.2) GOTO 1103
  186. DPAR1=DPAR-DIN*0.5D0
  187.  
  188. PARA=ANGLE*DPAR1
  189. COSA=COS(PARA)
  190. SINA=SIN(PARA)
  191.  
  192. XCOOR(IADR*(IDIM+1)+1)=XCEN+COSA*X1+SINA*X2
  193. XCOOR(IADR*(IDIM+1)+2)=YCEN+COSA*Y1+SINA*Y2
  194. IF (IDIM.EQ.3) THEN
  195. XCOOR(IADR*(IDIM+1)+3)=ZCEN+COSA*Z1+SINA*Z2
  196. ENDIF
  197.  
  198. XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR1
  199. IADR=IADR+1
  200.  
  201. 1103 PARA=ANGLE*DPAR
  202. COSA=COS(PARA)
  203. SINA=SIN(PARA)
  204.  
  205. XCOOR(IADR*(IDIM+1)+1)=XCEN+COSA*X1+SINA*X2
  206. XCOOR(IADR*(IDIM+1)+2)=YCEN+COSA*Y1+SINA*Y2
  207. IF (IDIM.EQ.3) THEN
  208. XCOOR(IADR*(IDIM+1)+3)=ZCEN+COSA*Z1+SINA*Z2
  209. ENDIF
  210.  
  211. XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR
  212. IADR=IADR+1
  213.  
  214. 301 CONTINUE
  215.  
  216. NBPTS = IADR
  217.  
  218.  
  219. SEGADJ MCOORD
  220.  
  221.  
  222. 300 DIN = TABPAR(NBELEM)
  223. DPAR=DPAR+DIN
  224.  
  225. IF (ITYPEL.NE.3) GOTO 303
  226.  
  227. NBPTS = IADR+1
  228. SEGADJ MCOORD
  229. DPAR1 = DPAR-DIN*0.5D0
  230.  
  231. PARA = ANGLE * DPAR1
  232. COSA = COS(PARA)
  233. SINA = SIN(PARA)
  234.  
  235. XCOOR(IADR*(IDIM+1)+1) = XCEN + X1*COSA + X2*SINA
  236. XCOOR(IADR*(IDIM+1)+2) = YCEN + Y1*COSA + Y2*SINA
  237. IF (IDIM.EQ.3) THEN
  238. XCOOR(IADR*(IDIM+1)+3) = ZCEN + Z1*COSA + Z2*SINA
  239. ENDIF
  240.  
  241. XCOOR((IADR+1)*(IDIM+1)) = DENI+DECA*DPAR1
  242. IADR=IADR + 1
  243.  
  244.  
  245. 303 DO 309 I=1,NUM(/2)
  246. ICOLOR(I)=IDCOUL
  247. 309 CONTINUE
  248. SEGSUP TABPAR
  249. SEGDES MELEME
  250.  
  251. CALL ECROBJ('MAILLAGE',MELEME)
  252. RETURN
  253. * Erreur 16 Type d'element incorrect
  254. 666 CONTINUE
  255. CALL ERREUR(16)
  256. RETURN
  257. END
  258.  
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  

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