Télécharger rond.eso

Retour à la liste

Numérotation des lignes :

  1. C ROND SOURCE GOUNAND 16/06/28 21:15:03 8988
  2. C 1234567890124567890124567898012456789012345678901234567890123456
  3.  
  4. C SOURCE : L. DI VALENTIN LE 17/06/97
  5.  
  6. C Cette subroutine appele par l'operateur LIGN (grace au mot cle
  7. C ROTA) prepare les donnees a transmettre a la subroutine ARC
  8. C pour construire un arc de cercle dont on connait le centre
  9. C (CENTRE), un point (POINT1) et l'angle d'ouverture en degre a
  10. C partir de ce point.
  11.  
  12. C En dimension 3, il est necessaire de fournir la normale au
  13. C cercle, ce qui fournit a la fois le plan contenant le cercle
  14. C et le sens trigonometrique positif dans ce plan.
  15.  
  16.  
  17. SUBROUTINE ROND
  18.  
  19.  
  20. IMPLICIT INTEGER(I-N)
  21. IMPLICIT REAL*8 (A-H,O-Z)
  22. -INC CCREEL
  23. -INC CCOPTIO
  24. -INC SMELEME
  25. -INC SMCOORD
  26.  
  27.  
  28. INTEGER INBR,IRET,POINT1,POINT2,NORMAL,CENTRE
  29. REAL*8 ANGLE,DENS1,DENS2,NORME
  30. CHARACTER*(4) TYPE*8
  31. CHARACTER*4 MOTCLE(2)
  32. logical ltelq
  33.  
  34.  
  35. DATA MOTCLE/'DINI','DFIN'/
  36.  
  37.  
  38. INBR = 0
  39. CALL LIRENT(INBR,0,IRET)
  40.  
  41.  
  42. * IF (DENS1*DENS2.LE.0.D0.AND.INBR.LE.0) THEN
  43. * CALL ERREUR(17)
  44. * RETURN
  45. * ENDIF
  46.  
  47.  
  48. C Lecture du centre.
  49.  
  50. CALL LIROBJ('POINT',CENTRE,1,IRET)
  51. IF (IRET.EQ.0) RETURN
  52.  
  53.  
  54. C Si on a un maillage, on extrait le dernier point
  55. IPT1=0
  56. CALL LIROBJ('MAILLAGE',IPT1,0,IRET)
  57. IF (IRET.EQ.1) THEN
  58. SEGACT IPT1
  59. CALL EXTRPO(IPT1,1,POINT1)
  60. ELSE
  61. CALL LIROBJ('POINT',POINT1,1,IRET)
  62. ENDIF
  63. IF (IERR.NE.0) RETURN
  64.  
  65. C Lecture de l'angle de rotation.
  66.  
  67. CALL LIRREE(ANGLE,1,IRET)
  68. IF (IRET.EQ.0) RETURN
  69.  
  70. ANGLE = ANGLE * XPI / 180.D0
  71.  
  72.  
  73. C En dimension 3, lecture du point fournissant le sens
  74. C trigonométrique
  75.  
  76. IF (IDIM.EQ.3) THEN
  77. CALL LIROBJ('POINT',NORMAL,1,IRET)
  78. IF (IRET.EQ.0) RETURN
  79. ENDIF
  80.  
  81.  
  82. C On recupere les coordonnees du CENTRE
  83.  
  84. XCEN = XCOOR((CENTRE-1)*(IDIM+1) + 1)
  85. YCEN = XCOOR((CENTRE-1)*(IDIM+1) + 2)
  86. IF (IDIM.EQ.3) THEN
  87. ZCEN = XCOOR((CENTRE-1)*(IDIM+1) + 3)
  88. ENDIF
  89. DENS2=XCOOR((CENTRE)*(IDIM+1))
  90.  
  91. C On recupere les coordonnees du vecteur (CENTRE -> POINT1)
  92.  
  93. X1 = XCOOR((POINT1-1)*(IDIM+1) + 1) - XCEN
  94. Y1 = XCOOR((POINT1-1)*(IDIM+1) + 2) - YCEN
  95.  
  96. IF (IDIM.EQ.3) THEN
  97. Z1 = XCOOR((POINT1-1)*(IDIM+1) + 3) - ZCEN
  98. ELSE
  99. Z1 = 0.D0
  100. ENDIF
  101. DENS1=XCOOR((POINT1)*(IDIM+1))
  102.  
  103. C On cree une place memoire pour le deuxieme point extremite
  104.  
  105. NBPTS = XCOOR(/1)/(IDIM + 1) + 1
  106. POINT2 = NBPTS
  107. SEGADJ MCOORD
  108.  
  109.  
  110. C Calcul des coordonnees de ce point :
  111.  
  112.  
  113. C Si IDIM = 3 on recupere le vecteur normal.
  114.  
  115. IF (IDIM.EQ.3) THEN
  116.  
  117. Xn = XCOOR((NORMAL-1)*(IDIM+1) + 1)
  118. Yn = XCOOR((NORMAL-1)*(IDIM+1) + 2)
  119. Zn = XCOOR((NORMAL-1)*(IDIM+1) + 3)
  120.  
  121. NORME = SQRT(Xn*Xn + Yn*Yn + Zn*Zn)
  122.  
  123. Xn = Xn/NORME
  124. Yn = Yn/NORME
  125. Zn = Zn/NORME
  126.  
  127. ELSE
  128.  
  129. Xn = 0.D0
  130. Yn = 0.D0
  131. Zn = 1.D0
  132.  
  133. ENDIF
  134.  
  135.  
  136. C POINT3 = NORMAL vectoriel POINT1 :
  137.  
  138. X3 = Yn*Z1 - Zn*Y1
  139. Y3 = Zn*X1 - Xn*Z1
  140. Z3 = Xn*Y1 - Yn*X1
  141.  
  142.  
  143. C Calcul des coordonnees de POINT2 (point extremite)
  144.  
  145. XCOOR((POINT2-1)*(IDIM+1) + 1) = XCEN + COS(ANGLE)*X1
  146. & + SIN(ANGLE)*X3
  147. XCOOR((POINT2-1)*(IDIM+1) + 2) = YCEN + COS(ANGLE)*Y1
  148. & + SIN(ANGLE)*Y3
  149. IF (IDIM.EQ.3) THEN
  150. XCOOR((POINT2-1)*(IDIM+1) + 3) = ZCEN + COS(ANGLE)*Z1
  151. & + SIN(ANGLE)*Z3
  152. ENDIF
  153. DENS2=SQRT(ABS(DENS1*DENS2))
  154. XCOOR(POINT2*(IDIM+1))=DENS2
  155.  
  156.  
  157. 413 CALL LIRMOT(MOTCLE,2,IRET,0)
  158.  
  159. IF (IRET.EQ.1) THEN
  160. CALL LIRREE(DENS1,1,IRET)
  161. IF (IRET.EQ.0) RETURN
  162. GOTO 413
  163.  
  164. ELSEIF (IRET.EQ.2) THEN
  165. CALL MESLIR(-169)
  166. CALL LIRREE(DENS2,1,IRET)
  167. IF (IRET.EQ.0) RETURN
  168. GOTO 413
  169.  
  170. ENDIF
  171.  
  172.  
  173. CALL ARC(POINT1,CENTRE,NORMAL,ANGLE,INBR,DENS1,DENS2,POINT2)
  174. IF (IERR.NE.0) RETURN
  175. IF (IPT1.NE.0) THEN
  176. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  177. IF (IERR.NE.0) RETURN
  178. SEGACT IPT1,IPT2
  179. ltelq=.false.
  180. CALL FUSE(IPT1,IPT2,IPT3,ltelq)
  181. IF (IERR.NE.0) RETURN
  182. SEGSUP IPT2
  183. SEGDES IPT1,IPT3
  184. CALL ECROBJ('MAILLAGE',IPT3)
  185. ENDIF
  186. RETURN
  187.  
  188. END
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  

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