Télécharger ksprjs.eso

Retour à la liste

Numérotation des lignes :

ksprjs
  1. C KSPRJS SOURCE CB215821 20/11/25 13:33:11 10792
  2. SUBROUTINE KSPRJS
  3. &(MELEME,IPM1,IPM2,IPM3,IAXI,IKAS,INEFMD,KPRE,IZTGG1,IPAD,IK1)
  4.  
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. C*****************************************************************************
  8. C
  9. C Ce SP calcule les matrices elementaires de divergence alias C
  10. C
  11. C IKAS=1 KMCT calcul de Ct (Div U)
  12. C IKAS=2 KMAC calcul de C uniquement (Grad p)
  13. C IKAS=3 KCCT calcul de C assemblage pour C et Ct
  14. C
  15. C*****************************************************************************
  16. CHARACTER*8 NOM0
  17.  
  18.  
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. -INC CCGEOME
  22. -INC SMCOORD
  23. -INC SIZFFB
  24. POINTEUR IZF1.IZFFM
  25. -INC SMELEME
  26. -INC SMLENTI
  27. -INC SMCHPOI
  28. POINTEUR IZTGG1.MPOVAL
  29. -INC CCREEL
  30. DIMENSION KIPM(3),XYZ1(24),UA(3),UB(3)
  31.  
  32.  
  33. C OPERATEUR PRESSION
  34. C
  35. MLENTI=IPAD
  36. DEUPI=1.D0
  37. IF(IAXI.NE.0)DEUPI=2.D0*XPI
  38. IF(IKAS.EQ.3)DEUPI=-DEUPI
  39.  
  40. IF(IDIM.EQ.2)IPM3=IPM1
  41. KIPM(1)=IPM1
  42. KIPM(2)=IPM2
  43. KIPM(3)=IPM3
  44. SEGACT MELEME,IPM1*MOD,IPM2*MOD,IPM3*MOD
  45.  
  46. NP=NUM(/1)
  47. NEL=NUM(/2)
  48.  
  49. C write(6,*)' INEFMD=',inefmd,'KPRE=',kpre
  50. IF(KPRE.NE.2)THEN
  51. IF(INEFMD.EQ.3)THEN
  52. IF(KPRE.EQ.3)NOM0=NOMS(ITYPEL)//'PRP0'
  53. IF(KPRE.EQ.4)NOM0=NOMS(ITYPEL)//'PRP1'
  54. IF(KPRE.EQ.5)NOM0=NOMS(ITYPEL)//'PRF1'
  55. ELSEIF(INEFMD.EQ.2)THEN
  56. IF(KPRE.EQ.3)NOM0=NOMS(ITYPEL)//'MCP0'
  57. IF(KPRE.EQ.4)NOM0=NOMS(ITYPEL)//'MCP1'
  58. IF(KPRE.EQ.5)NOM0=NOMS(ITYPEL)//'MCF1'
  59. ELSEIF(INEFMD.EQ.4)THEN
  60. NOM0=NOMS(ITYPEL)//' '
  61. ENDIF
  62. C write(6,*)' NOM0=',nom0,' ikas=',ikas,' nel=',nel
  63. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  64.  
  65. SEGACT IZFFM*MOD
  66. IZHR=KZHR(1)
  67. SEGACT IZHR*MOD
  68. NES=GR(/1)
  69. NPG=GR(/3)
  70. IZF1=KTP(1)
  71. SEGACT IZF1*MOD
  72. MP1=FN(/1)
  73.  
  74. DO 30 KE=1,NEL
  75.  
  76. DO I=1,NP
  77. J=NUM(I,KE)
  78. DO N=1,IDIM
  79. XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N)
  80. ENDDO
  81. ENDDO
  82.  
  83. CALL CALJBR
  84. &(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  85. C write(6,*)' Retour caljbr ',mp1,np,npg
  86.  
  87. DO 324 K=1,IDIM
  88. IPM4=KIPM(K)
  89. KG=(IK1-4)*(K-1)+1
  90.  
  91. DO M=1,MP1
  92.  
  93. DO I=1,NP
  94. U=0.D0
  95. DO 333 L=1,NPG
  96.  
  97. CALL INITD(UA,3,0.D0)
  98. CALL INITD(UB,3,0.D0)
  99.  
  100. DO 533 J=1,NP
  101. J1=LECT(NUM(J,KE))
  102. UA(KG)=UA(KG)+FN(J,L)*IZTGG1.VPOCHA(J1,KG)
  103. UB(K)=UB(K)+HR(K,J,L)*IZTGG1.VPOCHA(J1,KG)
  104. 533 CONTINUE
  105.  
  106. U=U+FN(M,L)*
  107. &(HR(K,I,L)*UA(KG) + FN(I,L)*UB(KG))*PGSQ(L)*DEUPI*RPG(L)
  108. IF(IAXI.NE.0.AND.K.EQ.1)THEN
  109. U=U+FN(M,L)*FN(I,L)*UA(KG)*PGSQ(L)*DEUPI
  110. ENDIF
  111.  
  112. 333 CONTINUE
  113.  
  114.  
  115. if(ikas.ne.2)then
  116. IPM4.AM(KE,I,M)=IPM4.AM(KE,I,M)+U
  117. else
  118. IPM4.AM(KE,M,I)=IPM4.AM(KE,M,I)+U
  119. endif
  120.  
  121. ENDDO
  122. ENDDO
  123. 324 CONTINUE
  124.  
  125. 37 CONTINUE
  126. 30 CONTINUE
  127.  
  128. SEGSUP IZHR,IZFFM
  129.  
  130.  
  131. C CAS MACRO CENTRE
  132.  
  133. ELSEIF(KPRE.EQ.2)THEN
  134. NOM0=NOMS(ITYPEL)//' '
  135. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  136.  
  137. SEGACT IZFFM*MOD
  138. IZHR=KZHR(1)
  139. SEGACT IZHR*MOD
  140. NES=GR(/1)
  141. NPG=GR(/3)
  142. IZF1=KTP(1)
  143. SEGACT IZF1*MOD
  144. MPG=IZF1.FN(/2)
  145. c modif tc initialisation de M à 1 ??? (izf1.fn(/1))
  146. M=1
  147.  
  148. NP=GR(/2)
  149.  
  150. DO 40 KE=1,NEL
  151.  
  152. IX=0
  153. DO I=1,NP
  154. J=NUM(I,KE)
  155. DO N=1,IDIM
  156. IX=IX+1
  157. XYZ1(IX)=XCOOR((J-1)*(IDIM+1) +N)
  158. ENDDO
  159. ENDDO
  160.  
  161. CALL CALJBR(FN,GR,PG,XYZ1,HR,PGSQ,RPG,NES,
  162. & IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  163.  
  164. DO 424 K=1,IDIM
  165. IPM4=KIPM(K)
  166. KG=(IK1-4)*(K-1)+1
  167.  
  168. DO 423 I=1,NP
  169. U=0.D0
  170. DO 433 L=1,NPG
  171.  
  172. CALL INITD(UA,3,0.D0)
  173. CALL INITD(UB,3,0.D0)
  174. DO 633 J=1,NP
  175. J1=LECT(NUM(J,KE))
  176. UA(KG)=UA(KG)+FN(J,L)*IZTGG1.VPOCHA(J1,KG)
  177. UB(K)=UB(K)+HR(K,J,L)*IZTGG1.VPOCHA(J1,KG)
  178. 633 CONTINUE
  179.  
  180. U=U+IZF1.FN(M,L)*
  181. &(HR(K,I,L)*UA(KG) + FN(I,L)*UB(KG))*PGSQ(L)*DEUPI*RPG(L)
  182. IF(IAXI.NE.0.AND.K.EQ.1)THEN
  183. U=U+IZF1.FN(M,L)*FN(I,L)*UA(KG)*PGSQ(L)*DEUPI
  184. ENDIF
  185.  
  186. 433 CONTINUE
  187.  
  188. if(ikas.ne.2)then
  189. IPM4.AM(KE,I,1)=IPM4.AM(KE,I,1)+U
  190. else
  191. IPM4.AM(KE,1,I)=IPM4.AM(KE,1,I)+U
  192. endif
  193.  
  194. 423 CONTINUE
  195. 424 CONTINUE
  196.  
  197. 40 CONTINUE
  198.  
  199. SEGSUP IZHR,IZFFM
  200.  
  201. ENDIF
  202.  
  203. RETURN
  204. 1002 FORMAT(10(1X,1PE11.4))
  205. 1040 FORMAT(1X,'CALCUL MATRICE AM ',I4/10(1X,1PE11.4))
  206. END
  207.  
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  
  220.  
  221.  
  222.  
  223.  
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  

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