Télécharger kpriss.eso

Retour à la liste

Numérotation des lignes :

  1. C KPRISS SOURCE PV 16/11/17 22:00:18 9180
  2. SUBROUTINE KPRISS(MELEME,IPM1,IPM2,IPM3,IAXI,IKAS,MACRO,KPRE)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C*****************************************************************************
  6. C
  7. C Ce SP calcule les matrices elementaires de divergence alias C
  8. C
  9. C*****************************************************************************
  10. CHARACTER*8 NOM0
  11.  
  12. -INC CCOPTIO
  13. -INC CCGEOME
  14. -INC SMCOORD
  15. -INC SIZFFB
  16. POINTEUR IZF1.IZFFM
  17. -INC SMELEME
  18. -INC CCREEL
  19. DIMENSION KIPM(3),XYZ1(24)
  20.  
  21.  
  22. C OPERATEUR PRESSION
  23. C
  24. DEUPI=1.D0
  25. IF(IAXI.NE.0)DEUPI=2.D0*XPI
  26.  
  27. C write(6,*)' DEUPI=',deupi
  28. IF(IDIM.EQ.2)IPM3=IPM1
  29. KIPM(1)=IPM1
  30. KIPM(2)=IPM2
  31. KIPM(3)=IPM3
  32. SEGACT MELEME,IPM1*MOD,IPM2*MOD,IPM3*MOD
  33.  
  34. NP=NUM(/1)
  35. NEL=NUM(/2)
  36.  
  37. IF(KPRE.NE.2)THEN
  38. IF(MACRO.EQ.0)THEN
  39. IF(KPRE.EQ.3)NOM0=NOMS(ITYPEL)//'PRP0'
  40. IF(KPRE.EQ.4)NOM0=NOMS(ITYPEL)//'PRP1'
  41. ELSE
  42. IF(KPRE.EQ.3)NOM0=NOMS(ITYPEL)//'MCP0'
  43. IF(KPRE.EQ.4)NOM0=NOMS(ITYPEL)//'MCP1'
  44. ENDIF
  45. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  46. C write(6,*)' NOM0=',nom0,' ikas=',ikas,' nel=',nel
  47.  
  48. SEGACT IZFFM*MOD
  49. IZHR=KZHR(1)
  50. SEGACT IZHR*MOD
  51. NES=GR(/1)
  52. NPG=GR(/3)
  53. IZF1=KTP(1)
  54. SEGACT IZF1*MOD
  55. MP1=IZF1.FN(/1)
  56.  
  57. DO 30 KE=1,NEL
  58. DO 12 I=1,NP
  59. J=NUM(I,KE)
  60. DO 12 N=1,IDIM
  61. XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N)
  62. 12 CONTINUE
  63.  
  64. CALL CALJBR
  65. &(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  66. C write(6,*)' Retour caljbr ',mp1,np,npg
  67.  
  68. DO 324 K=1,IDIM
  69. IPM4=KIPM(K)
  70.  
  71. DO 323 M=1,MP1
  72.  
  73. DO 323 I=1,NP
  74. U=0.D0
  75. DO 333 L=1,NPG
  76. U=U+IZF1.FN(M,L)*HR(K,I,L)*PGSQ(L)*DEUPI*RPG(L)
  77. 333 CONTINUE
  78.  
  79. IF(IAXI.NE.0.AND.K.EQ.1)THEN
  80. DO 334 L=1,NPG
  81. U=U+IZF1.FN(M,L)*FN(I,L)*PGSQ(L)*DEUPI
  82. 334 CONTINUE
  83. ENDIF
  84.  
  85. if(ikas.ne.2)then
  86. IPM4.AM(KE,I,M)=IPM4.AM(KE,I,M)+U
  87. else
  88. IPM4.AM(KE,M,I)=IPM4.AM(KE,M,I)+U
  89. endif
  90.  
  91. 323 CONTINUE
  92. 324 CONTINUE
  93.  
  94. 37 CONTINUE
  95. 30 CONTINUE
  96.  
  97. SEGSUP IZHR,IZFFM
  98.  
  99.  
  100. C CAS MACRO CENTRE
  101.  
  102. ELSEIF(KPRE.EQ.2)THEN
  103. NOM0=NOMS(ITYPEL)//' '
  104. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  105.  
  106. SEGACT IZFFM*MOD
  107. IZHR=KZHR(1)
  108. SEGACT IZHR*MOD
  109. NES=GR(/1)
  110. NPG=GR(/3)
  111. IZF1=KTP(1)
  112. SEGACT IZF1*MOD
  113. MPG=IZF1.FN(/2)
  114. NP=GR(/2)
  115.  
  116. DO 40 KE=1,NEL
  117.  
  118. IX=0
  119. DO 42 I=1,NP
  120. J=NUM(I,KE)
  121. DO 42 N=1,IDIM
  122. IX=IX+1
  123. XYZ1(IX)=XCOOR((J-1)*(IDIM+1) +N)
  124. 42 CONTINUE
  125.  
  126. CALL CALJBR(FN,GR,PG,XYZ1,HR,PGSQ,RPG,NES,
  127. & IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  128.  
  129. DO 424 K=1,IDIM
  130. IPM4=KIPM(K)
  131.  
  132. DO 423 I=1,NP
  133. U=0.D0
  134. DO 433 L=1,NPG
  135. U=U+HR(K,I,L)*PGSQ(L)*DEUPI*RPG(L)
  136. 433 CONTINUE
  137.  
  138. IF(IAXI.NE.0.AND.K.EQ.1)THEN
  139. DO 434 L=1,NPG
  140. U=U+FN(I,L)*PGSQ(L)*DEUPI
  141. 434 CONTINUE
  142. ENDIF
  143.  
  144. if(ikas.ne.2)then
  145. IPM4.AM(KE,I,1)=IPM4.AM(KE,I,1)+U
  146. else
  147. IPM4.AM(KE,1,I)=IPM4.AM(KE,1,I)+U
  148. endif
  149.  
  150. 423 CONTINUE
  151. 424 CONTINUE
  152.  
  153. 40 CONTINUE
  154.  
  155. SEGSUP IZHR,IZFFM
  156.  
  157. ENDIF
  158.  
  159. RETURN
  160. 1002 FORMAT(10(1X,1PE11.4))
  161. 1040 FORMAT(1X,'CALCUL MATRICE AM ',I4/10(1X,1PE11.4))
  162. END
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  

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