Télécharger kcalar.eso

Retour à la liste

Numérotation des lignes :

  1. C KCALAR SOURCE CB215821 16/04/22 21:15:03 8922
  2. SUBROUTINE KCALAR(NR,XR1,IF1,KF1,XR2,IF2,KF2,NBFA,IFA,IG,NCEL,ICEL
  3. - ,IC,KA,IM)
  4.  
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7.  
  8. C--------------------------------------------------------------------
  9. C Calcul des facteurs de forme en 3D
  10. C Sp appele par KPROJA
  11. C
  12. C DETERMINATION DE LA PROJECTION D' UNE ARETE CONNUE PAR LA
  13. C PROJECTION DE SES SOMMETS SUR L'H.C DE RESOLUTION NR
  14. C
  15. C--------------------------------------------------------------------
  16. DIMENSION XR1(3),KF1(2),XR2(3),KF2(2)
  17. DIMENSION IFA(3),IG(3,2),NCEL(3),ICEL(3,2,1),IC(2,1)
  18. DIMENSION KA(6),IM(6)
  19. DIMENSION P(3),M1(2),M2(2),KG(2)
  20. C
  21. NR2 = NR/2
  22. C WRITE(6,*) ' IF1 IF2 ',IF1,IF2
  23. C WRITE(6,*) ' XR1 ',XR1(1),XR1(2),XR1(3)
  24. C WRITE(6,*) ' XR2 ',XR2(1),XR2(2),XR2(3)
  25. IF ( IF1.EQ.IF2) THEN
  26. NBFA = 1
  27. IFA(1) = IF1
  28. CALL KBRESE(KF1,KF2,NC,IC,KG)
  29. IG(1,1) = KG(1)
  30. IG(1,2) = KG(2)
  31. NCEL(1) = NC
  32. DO 1 I = 1,NC
  33. ICEL(1,1,I) = IC(1,I)
  34. ICEL(1,2,I) = IC(2,I)
  35. 1 CONTINUE
  36. ELSE
  37. IFA(1) = IF1
  38. IFA(2) = IF2
  39. K1 = KA(IF1)
  40. K2 = KA(IF2)
  41. IF(K1.EQ.K2) THEN
  42. NBFA = 0
  43. RETURN
  44. ELSE
  45. K3 = 6- K1- K2
  46. I1 = IM(IF1)
  47. I2 = IM(IF2)
  48. CALL KPVEC(XR1,XR2,P)
  49. C WRITE(6,*) ' P ',P(1),P(2),P(3)
  50. CV = ABS(P(K3))
  51. C WRITE(6,*) ' CV ',CV
  52. IF (CV.GT.1E-4) THEN
  53. Y = XR1(K3) - (P(K2)/P(K3))*( XR2(K2) - XR1(K2))
  54. ELSE
  55. Y = XR1(K3)
  56. ENDIF
  57. C WRITE(6,*) ' Y ',Y
  58. AY = ABS(Y)
  59.  
  60. IF(AY.LE.1.001) THEN
  61. NBFA = 2
  62. IIY = 1 + INT(NR2*(1.+Y))
  63. IY = MIN0(NR,IIY)
  64. C WRITE(6,*) ' IY ',IY
  65.  
  66. IF( K2.LT.K3) THEN
  67. M1(1) = I2
  68. M1(2) = IY
  69. ELSE
  70. M1(1) = IY
  71. M1(2) = I2
  72. ENDIF
  73. CALL KBRESE(KF1,M1,NC,IC,KG)
  74. NCEL(1) = NC
  75. DO 2 I = 1,NC
  76. ICEL(1,1,I) = IC(1,I)
  77. ICEL(1,2,I) = IC(2,I)
  78. 2 CONTINUE
  79. C IG(1,1) = KG(1)
  80. C IG(1,2) = KG(2)
  81. IG(1,1) = M1(1)
  82. IG(1,2) = M1(2)
  83.  
  84. IF( K1.LT.K3) THEN
  85. M2(1) = I1
  86. M2(2) = IY
  87. ELSE
  88. M2(1) = IY
  89. M2(2) = I1
  90. ENDIF
  91. CALL KBRESE(KF2,M2,NC,IC,KG)
  92. NCEL(2) = NC
  93. DO 3 I = 1,NC
  94. ICEL(2,1,I) = IC(1,I)
  95. ICEL(2,2,I) = IC(2,I)
  96. 3 CONTINUE
  97. C IG(2,1) = KG(1)
  98. C IG(2,2) = KG(2)
  99. IG(2,1) = M2(1)
  100. IG(2,2) = M2(2)
  101.  
  102. ELSE
  103. NBFA = 3
  104. I3 = IM(IF1)
  105.  
  106. IF(Y.GT.0.) THEN
  107. Y = 1.
  108. IFA(3) = 2*K3 - 1
  109. ELSE
  110. Y= -1.
  111. IFA(3) = 2*K3
  112. ENDIF
  113. I3 = IM(IFA(3))
  114.  
  115. CV = ABS(P(K2))
  116. IF (CV.GT.1E-4) THEN
  117. X = XR1(K2) - (P(K3)/P(K2))*( Y - XR1(K3))
  118. ELSE
  119. X = XR1(K2)
  120. ENDIF
  121.  
  122. CV = ABS(P(K1))
  123. IF (CV.GT.1E-4) THEN
  124. Z = XR2(K1) - (P(K3)/P(K1))*( Y - XR2(K3))
  125. ELSE
  126. Z = XR2(K1)
  127. ENDIF
  128. C WRITE(6,*) ' X Z ',X,Z
  129. IIX = 1 + INT(NR2*(1+X))
  130. IX = MIN0(NR,IIX)
  131. IIZ = 1 + INT(NR2*(1+Z))
  132. IZ = MIN0(NR,IIZ)
  133.  
  134. C FACE IF3
  135. IF( K1.LT.K2) THEN
  136. M1(1) = I1
  137. M1(2) = IX
  138. M2(1) = IZ
  139. M2(2) = I2
  140. ELSE
  141. M1(1) = IX
  142. M1(2) = I1
  143. M2(1) = I2
  144. M2(2) = IZ
  145. ENDIF
  146. CALL KBRESE(M1,M2,NC,IC,KG)
  147. NCEL(3) = NC
  148. DO 4 I = 1,NC
  149. ICEL(3,1,I) = IC(1,I)
  150. ICEL(3,2,I) = IC(2,I)
  151. 4 CONTINUE
  152. IG(3,1) = KG(1)
  153. IG(3,2) = KG(2)
  154.  
  155. C FACE IF1
  156. IF( K2.LT.K3) THEN
  157. M1(1) = IX
  158. M1(2) = I3
  159. ELSE
  160. M1(1) = I3
  161. M1(2) = IX
  162. ENDIF
  163. CALL KBRESE(KF1,M1,NC,IC,KG)
  164. NCEL(1) = NC
  165. DO 5 I = 1,NC
  166. ICEL(1,1,I) = IC(1,I)
  167. ICEL(1,2,I) = IC(2,I)
  168. 5 CONTINUE
  169. C IG(1,1) = KG(1)
  170. C IG(1,2) = KG(2)
  171. IG(1,1) = M1(1)
  172. IG(1,2) = M1(2)
  173.  
  174. C FACE IF2
  175. IF( K1.LT.K3) THEN
  176. M2(1) = IZ
  177. M2(2) = I3
  178. ELSE
  179. M2(1) = I3
  180. M2(2) = IZ
  181. ENDIF
  182. CALL KBRESE(KF2,M2,NC,IC,KG)
  183. NCEL(2) = NC
  184. DO 6 I = 1,NC
  185. ICEL(2,1,I) = IC(1,I)
  186. ICEL(2,2,I) = IC(2,I)
  187. 6 CONTINUE
  188. C IG(2,1) = KG(1)
  189. C IG(2,2) = KG(2)
  190. IG(2,1) = M2(1)
  191. IG(2,2) = M2(2)
  192.  
  193. ENDIF
  194. ENDIF
  195. ENDIF
  196.  
  197. C WRITE(6,*) ' NBFA ',NBFA
  198. C WRITE(6,*) ' IFA ',(IFA(I),I=1,NBFA)
  199. C WRITE(6,*) ' NCEL ',(NCEL(I),I=1,NBFA)
  200. C DO 10 I = 1,NBFA
  201. C WRITE(6,*) ' IG ',IG(I,1),IG(I,2)
  202. C WRITE(6,*) ' ICEL ',(ICEL(I,1,K),K=1,NCEL(I))
  203. C WRITE(6,*) ' JCEL ',(ICEL(I,2,K),K=1,NCEL(I))
  204. C10 CONTINUE
  205. C WRITE(6,*)
  206. RETURN
  207. END
  208.  
  209.  

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