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

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