Télécharger kproja.eso

Retour à la liste

Numérotation des lignes :

kproja
  1. C KPROJA SOURCE CHAT 05/01/13 01:05:08 5004
  2. SUBROUTINE KPROJA(O1,XG1,XG2,X1,KF1,KC1,X2,KF2,KC2,I,SPROJA,SHC3D)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C----------------------------------------------------------------------
  6. C Calcul des facteurs de forme en 3D
  7. C Sp appele par Kprojf et Ksubcr
  8. C
  9. C PROJECTION DES ARETES
  10. C ---------------------
  11. C
  12. C O1 : POINT SUR L'ELEMENT 1
  13. C XG1: COORDONNEES GLOBALES DU SOMMET 1
  14. C X1 : COORDONNEES SUR L'H.C
  15. C KF1: FACE SUR L'H.C
  16. C KC1: COORDONNEES ENTIERES SUR L'H.C
  17. C idem point 2
  18. C----------------------------------------------------------------------
  19. -INC TFFOR3D
  20. C
  21. DIMENSION X1(3),X2(3),KC1(2),KC2(2)
  22. DIMENSION IFAC(3),IGC(3,2),NCELC(3)
  23. DIMENSION O1(3),X(3),XR(3),KI(2),XG1(1),XG2(1)
  24. C
  25. C WRITE(6,*) ' KPROJA KF ',KF1,KF2
  26. C WRITE(6,*) ' KPROJA KA ',KA(KF1),KA(KF2)
  27. C WRITE(6,*) ' XG1 ',XG1(1),XG1(2),XG1(3)
  28. C WRITE(6,*) ' XG2 ',XG2(1),XG2(2),XG2(3)
  29.  
  30. IF ((KA(KF1).NE.KA(KF2)).OR.(KF1.EQ.KF2)) THEN
  31.  
  32. CALL KCALAR(NRES,X1,KF1,KC1,X2,KF2,KC2,
  33. - NFAC,IFAC,IGC,NCELC,ICELC,IC,KA,IM)
  34.  
  35. C WRITE(6,*) ' IF1 IF2 NFA ',KF(NP1),KF(NP2),NFAC KAR02020
  36. C WRITE(6,*) ' X1 ',X1(1),X1(2),X1(3)
  37. C WRITE(6,*) ' X2 ',X2(1),X2(2),X2(3)
  38.  
  39. NFA(I) = NFAC
  40. DO 332 J = 1,NFAC
  41. IFA(J,I) = IFAC(J)
  42. NCEL(J,I) = NCELC(J)
  43. IG(J,1,I) = IGC(J,1)
  44. IG(J,2,I) = IGC(J,2)
  45. DO 334 K = 1,NCELC(J)
  46. ICEL(J,1,K,I) = ICELC(J,1,K)
  47. ICEL(J,2,K,I) = ICELC(J,2,K)
  48. 334 CONTINUE
  49. 332 CONTINUE
  50.  
  51. ELSE
  52.  
  53. DO 1 K=1,KES
  54. X(K) = (XG1(K)+XG2(K))/2
  55. 1 CONTINUE
  56. C
  57. II = 0
  58. C WRITE(6,*) ' KA ',KA(KF1)
  59. KAC = KA(KF1)
  60. 10 CONTINUE
  61. II = II + 1
  62. C IF (II.GT.20) CALL ARRET(0)
  63. C 05-90
  64. IF (II.GT.20) THEN
  65. RETURN
  66. ENDIF
  67. CALL KAPCU1(KES,X,O1,NRES,XR,KF,KI,KAC)
  68. C WRITE(6,*) ' KF ',KF
  69. C WRITE(6,*) ' O1 ',O1(1),O1(2),O1(3)
  70.  
  71. IF (KF.EQ.KF1) THEN
  72.  
  73. DO 2 K = 1,KES
  74. X(K) = (X(K)+XG2(K))/2
  75. 2 CONTINUE
  76. GOTO 10
  77. ELSE
  78. IF(KF.EQ.KF2) THEN
  79. DO 3 K = 1,KES
  80. X(K) = (XG1(K)+X(K))/2
  81. 3 CONTINUE
  82. GOTO 10
  83. ELSE
  84.  
  85. C KF1 KF2 KF KFP
  86. C
  87. CALL KCALAR(NRES,X1,KF1,KC1,XR,KF,KI,
  88. - NFAC,IFAC,IGC,NCELC,ICELC,IC,KA,IM)
  89.  
  90. IFA(1,I) = IFAC(1)
  91. NCEL(1,I) = NCELC(1)
  92. IG(1,1,I) = IGC(1,1)
  93. IG(1,2,I) = IGC(1,2)
  94. DO 300 K = 1,NCELC(1)
  95. ICEL(1,1,K,I) = ICELC(1,1,K)
  96. ICEL(1,2,K,I) = ICELC(1,2,K)
  97. 300 CONTINUE
  98.  
  99. IFA(3,I) = IFAC(2)
  100. NCEL(3,I) = NCELC(2)
  101. IG(3,1,I) = IGC(2,1)
  102. IG(3,2,I) = IGC(2,2)
  103. DO 301 K = 1,NCELC(2)
  104. ICEL(3,1,K,I) = ICELC(2,1,K)
  105. ICEL(3,2,K,I) = ICELC(2,2,K)
  106. 301 CONTINUE
  107.  
  108. IF (NFAC.EQ.3) THEN
  109. IFA(4,I) = IFAC(3)
  110. NCEL(4,I) = NCELC(3)
  111. IG(4,1,I) = IGC(3,1)
  112. IG(4,2,I) = IGC(3,2)
  113. DO 302 K = 1,NCELC(3)
  114. ICEL(4,1,K,I) = ICELC(3,1,K)
  115. ICEL(4,2,K,I) = ICELC(3,2,K)
  116. 302 CONTINUE
  117. NFA(I) = 4
  118. ELSE
  119. NFA(I) = 3
  120. ENDIF
  121.  
  122. ENDIF
  123.  
  124. CALL KCALAR(NRES,X2,KF2,KC2,XR,KF,KI,
  125. - NFAC,IFAC,IGC,NCELC,ICELC,IC,KA,IM)
  126.  
  127.  
  128. IFA(2,I) = IFAC(1)
  129. NCEL(2,I) = NCELC(1)
  130. IG(2,1,I) = IGC(1,1)
  131. IG(2,2,I) = IGC(1,2)
  132. DO 303 K = 1,NCELC(1)
  133. ICEL(2,1,K,I) = ICELC(1,1,K)
  134. ICEL(2,2,K,I) = ICELC(1,2,K)
  135. 303 CONTINUE
  136.  
  137. IG(3,1,I) = (IG(3,1,I) + IGC(2,1)) /2
  138. IG(3,2,I) = (IG(3,2,I) + IGC(2,2)) /2
  139. C DO 304 K1 = 1,NCELC(2)-1
  140.  
  141. DO 304 K1 = 1,NCELC(2)
  142. K = K1 + NCEL(3,I)
  143. ICEL(3,1,K,I) = ICELC(2,1,K1)
  144. ICEL(3,2,K,I) = ICELC(2,2,K1)
  145. 304 CONTINUE
  146. C NCEL(3,I) = NCEL(3,I) + NCELC(2)-1
  147.  
  148. NCEL(3,I) = NCEL(3,I) + NCELC(2)
  149.  
  150. IF (NFAC.EQ.3) THEN
  151. IF(NFA(I).EQ.3) THEN
  152.  
  153. IFA(4,I) = IFAC(3)
  154. NCEL(4,I) = NCELC(3)
  155. IG(4,1,I) = IGC(3,1)
  156. IG(4,2,I) = IGC(3,2)
  157. DO 305 K = 1,NCELC(3)
  158. ICEL(4,1,K,I) = ICELC(3,1,K)
  159. ICEL(4,2,K,I) = ICELC(3,2,K)
  160. 305 CONTINUE
  161. NFA(I) = 4
  162. ELSE
  163. WRITE(6,*) ' ERREUR '
  164. ENDIF
  165. ENDIF
  166.  
  167. ENDIF
  168.  
  169. ENDIF
  170.  
  171. C WRITE(6,*) ' VERIF ',NFA(I)
  172. C NFAC = NFA(I)
  173. C WRITE(6,*) ' IFA ',(IFA(I1,I),I1=1,NFAC) KAR02030
  174. C WRITE(6,*) ' NCEL ',(NCEL(I1,I),I1=1,NFAC) KAR02040
  175. C DO 105 I1 = 1,NFAC KAR02050
  176. C WRITE(6,*) ' IG ',IG(I1,1,I),IG(I1,2,I) KAR02060
  177. C WRITE(6,*) ' ICEL ',(ICEL(I1,1,K,I),K=1,NCEL(I1,I)) KAR02070
  178. C WRITE(6,*) ' JCEL ',(ICEL(I1,2,K,I),K=1,NCEL(I1,I)) KAR02080
  179. C105 CONTINUE
  180. C WRITE(6,*) ' '
  181.  
  182. RETURN
  183. END
  184.  
  185.  
  186.  

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