Télécharger conge4.eso

Retour à la liste

Numérotation des lignes :

  1. C CONGE4 SOURCE CHAT 05/01/12 22:17:15 5004
  2. SUBROUTINE CONGE4 (L1,L2,RCONGE,NCONGE, NL1,LRAC,NL2)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. ************************************************************************
  6. *
  7. * C O N G E 4
  8. * -----------
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. * CREER UN CONGE DE RACCORDEMENT ENTRE DEUX LIGNES NON COPLANAIRES
  14. *
  15. * TYPE DU CONGE : DOUBLE COUDE
  16. *
  17. *
  18. * MODULES UTILISES:
  19. * -----------------
  20. *
  21. -INC CCOPTIO
  22. -INC SMELEME
  23. -INC CCREEL
  24. *
  25. * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN)
  26. * -----------
  27. *
  28. * L1 (E) PREMIERE LIGNE A RACCORDER
  29. * L2 (E) DEUXIEME LIGNE A RACCORDER
  30. * RCONGE (E) RAYON DU CONGE DU RACCORDEMENT
  31. * NCONGE (E) FACTEUR DE DECOUPAGE DU CONGE (CONVENTIONS
  32. * CLASSIQUES SUR SON SIGNE)
  33. * = 0 SI NON FOURNI
  34. * NL1 (S) LIGNE APPUYEE SUR L1 ET ABOUTISSANT SUR LE CONGE
  35. * LRAC (S) CONGE DE RACCORDEMENT
  36. * NL2 (S) LIGNE APPUYEE SUR L2 ET COMMENCANT SUR LE CONGE
  37. *
  38. INTEGER NCONGE
  39. REAL*8 RCONGE
  40. *
  41. * CONSTANTES:
  42. * -----------
  43. *
  44. *
  45. PARAMETER (DEMI=0.5D0)
  46. *
  47. * VARIABLES:
  48. * ----------
  49. *
  50. INTEGER N,NBNOEU,NBELEM,NL,ND,
  51. & ITYPLM,NBSOUS,NBREF,NBNN
  52. REAL*8 MU,L
  53. *
  54. *
  55. * AUTEUR, DATE DE CREATION:
  56. * -------------------------
  57. *
  58. * GILLES DUVERGER 06 OCTOBRE 1988
  59. *
  60. * LANGAGE:
  61. * --------
  62. *
  63. * ESOPE + FORTRAN77
  64. *
  65. ************************************************************************
  66. *
  67. MELEME=L1
  68. SEGACT,MELEME
  69. NL=LISOUS(/1)
  70. IF (NL.NE.0) THEN
  71. CALL ERREUR(25)
  72. RETURN
  73. END IF
  74. NBNOEU=NUM(/1)
  75. NBELEM=NUM(/2)
  76. IP9=NUM(NBNOEU,NBELEM)
  77. IP8=NUM(1,NBELEM)
  78. SEGDES,MELEME
  79. *
  80. MELEME=L2
  81. SEGACT,MELEME
  82. NL=LISOUS(/1)
  83. IF (NL.NE.0) THEN
  84. CALL ERREUR(25)
  85. RETURN
  86. END IF
  87. NBNOEU=NUM(/1)
  88. IP1=NUM(1,1)
  89. IP2=NUM(NBNOEU,1)
  90. SEGDES,MELEME
  91. *
  92. CALL EXCOO1(IP9,X9,Y9,Z9,D9)
  93. CALL EXCOO1(IP8,X8,Y8,Z8,D8)
  94. CALL EXCOO1(IP1,X1,Y1,Z1,D1)
  95. CALL EXCOO1(IP2,X2,Y2,Z2,D2)
  96. *
  97. * VECTEURS DIRECTEURS DE L1 ET L2
  98. *
  99. XN9 = SQRT((X8-X9)**2+(Y8-Y9)**2+(Z8-Z9)**2)
  100. XN1 = SQRT((X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2)
  101. A1=(X8-X9)/XN9
  102. B1=(Y8-Y9)/XN9
  103. C1=(Z8-Z9)/XN9
  104. A2=(X2-X1)/XN1
  105. B2=(Y2-Y1)/XN1
  106. C2=(Z2-Z1)/XN1
  107. *
  108. * RECHERCHE DES POINTS M1 SUR L1 ET M2 SUR L2 TELS QUE
  109. * D(M1;M2) = D(L1;L2)
  110. *
  111. B=-(A1*A2+B1*B2+C1*C2)
  112. *
  113. D=(X1-X9)*A1+(Y1-Y9)*B1+(Z1-Z9)*C1
  114. E=-((X1-X9)*A2+(Y1-Y9)*B2+(Z1-Z9)*C2)
  115. ALPHA=(B*E-D)/(B**2-1)
  116. BETA=(B*D-E)/(B**2-1)
  117. *
  118. XM1=X9+ALPHA*A1
  119. YM1=Y9+ALPHA*B1
  120. ZM1=Z9+ALPHA*C1
  121. CALL CREPO1(XM1,YM1,ZM1,IPM1)
  122. XM2=X1+BETA*A2
  123. YM2=Y1+BETA*B2
  124. ZM2=Z1+BETA*C2
  125. CALL CREPO1(XM2,YM2,ZM2,IPM2)
  126. *
  127. * DISTANCE ENTRE LES DEUX DROITES
  128. *
  129. D2D=SQRT((XM2-XM1)**2+(YM2-YM1)**2+(ZM2-ZM1)**2)
  130. *
  131. * TEST DE LA VALEUR DE RCONGE
  132. *
  133. IF (RCONGE.LT.(D2D*DEMI)) THEN
  134. CALL ERREUR(401)
  135. RETURN
  136. END IF
  137. *
  138. * CALCUL PREALABLE
  139. *
  140. BB=D2D*D2D
  141. AA=2*(1+B)
  142. MU=-(1+B)
  143. *
  144. S=(BB*AA+2*AA*(BB-4*RCONGE*RCONGE)-2*MU*MU*(BB+4*RCONGE*RCONGE))
  145. &/(AA*(AA-MU*MU))
  146. T=(AA*(BB-4*RCONGE*RCONGE)*(BB-4*RCONGE*RCONGE)+2*AA*BB*(BB-4*
  147. &RCONGE*RCONGE)-MU*MU*(BB+4*RCONGE*RCONGE)*(BB+4*RCONGE*RCONGE))/
  148. &(AA*AA*(AA-MU*MU))
  149. U=BB*(BB-4*RCONGE*RCONGE)/(AA*AA*(AA-MU*MU))
  150. *
  151. CALL DEGRE3(U,T,S,XR1,XI1,XR2,XI2,XR3,XI3)
  152. *
  153. QQ=T/3-S*S/9
  154. RR=(T*S-3*U)/6-S*S*S/27
  155. D=QQ*QQ*QQ+RR*RR
  156. IF (D .LT. 0) THEN
  157. X=MAX(XR1,XR2,XR3)
  158. ELSE
  159. X=XR1
  160. END IF
  161. L=SQRT(AA*X+BB)*COS(XPI-2*ATAN(SQRT(AA*X+BB)/(2*RCONGE)))/MU
  162. *
  163. * RECHERCHE DU POINT P1 SUR L1
  164. *
  165. XP1=XM1+L*A1
  166. YP1=YM1+L*B1
  167. ZP1=ZM1+L*C1
  168. CALL CREPO1(XP1,YP1,ZP1,IPP1)
  169. *
  170. * RECHERCHE DU POINT P2 SUR L2
  171. *
  172. * JE PENSE QUE LAMBDA VAUT 1 PV
  173. LAMBDA=1
  174. XP2=XM2+LAMBDA*L*A2
  175. YP2=YM2+LAMBDA*L*B2
  176. ZP2=ZM2+LAMBDA*L*C2
  177. CALL CREPO1(XP2,YP2,ZP2,IPP2)
  178. *
  179. * RECHERCHE DU POINT O ,MILIEU DE P1 P2
  180. *
  181. XO=(XP1+XP2)*DEMI
  182. YO=(YP1+YP2)*DEMI
  183. ZO=(ZP1+ZP2)*DEMI
  184. CALL CREPO1(XO,YO,ZO,IPO)
  185. *
  186. * CREATION DE LA DROITE P1-O
  187. *
  188. ND=1
  189. CALL ECRENT(ND)
  190. CALL ECROBJ('POINT',IPO)
  191. CALL ECROBJ('POINT',IPP1)
  192. CALL LIGNE(1,1,DEN1,DEN2,N)
  193. IF (IERR.NE.0) RETURN
  194. CALL LIROBJ('MAILLAGE',L3,1,IRETOU)
  195. IF (IERR.NE.0) RETURN
  196. *
  197. * CREATION DE LA DROITE O-P2
  198. *
  199. ND=1
  200. CALL ECRENT(ND)
  201. CALL ECROBJ('POINT',IPP2)
  202. CALL ECROBJ('POINT',IPO)
  203. CALL LIGNE(1,1,DEN1,DEN2,N)
  204. IF (IERR.NE.0) RETURN
  205. CALL LIROBJ('MAILLAGE',L4,1,IRETOU)
  206. IF (IERR.NE.0) RETURN
  207. *
  208. * CREATION DU CONGE DOUBLE
  209. *
  210. NCONGE=(NCONGE+1)/2
  211. CALL CONGE2(L1,L4,RCONGE,NCONGE,NL1,LRAC1,NL4)
  212. IF (IERR.NE.0) RETURN
  213. CALL CONGE2(L3,L2,RCONGE,NCONGE,NL3,LRAC2,NL2)
  214. IF (IERR.NE.0) RETURN
  215. *
  216. * LES 2 ARCS DE CERCLE ONT UN POINT EN COMMUN:
  217. MELEME=LRAC1
  218. SEGACT,MELEME
  219. NBNOEU=NUM(/1)
  220. NBELEM=NUM(/2)
  221. IPO1=NUM(NBNOEU,NBELEM)
  222. SEGDES,MELEME
  223. MELEME=LRAC2
  224. SEGACT,MELEME
  225. NUM(1,1)=IPO1
  226. SEGDES,MELEME
  227. * ON REUNIT LES 2 DEMI-CERCLES:
  228. CALL ECROBJ('MAILLAGE',LRAC2)
  229. CALL ECROBJ('MAILLAGE',LRAC1)
  230. CALL PRFUSE
  231. IF (IERR.NE.0) RETURN
  232. CALL LIROBJ('MAILLAGE',LRAC,1,IRETOU)
  233. IF (IERR.NE.0) RETURN
  234. MELEME=LRAC1
  235. SEGSUP,MELEME
  236. MELEME=LRAC2
  237. SEGSUP,MELEME
  238. *
  239. MELEME=L3
  240. SEGSUP,MELEME
  241. MELEME=NL3
  242. SEGSUP,MELEME
  243. MELEME=L4
  244. SEGSUP,MELEME
  245. MELEME=NL4
  246. SEGSUP,MELEME
  247. *
  248.  
  249. END
  250.  
  251.  
  252.  
  253.  

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