Télécharger kpsoml.eso

Retour à la liste

Numérotation des lignes :

kpsoml
  1. C KPSOML SOURCE CB215821 20/11/25 13:32:54 10792
  2. SUBROUTINE KPSOML
  3. C************************************************************************
  4. C
  5. C OBJET :
  6. C
  7. C CALCUL DE LA MATRICE MASSE ---> Creation d'un CHAML
  8. C
  9. C
  10. C SYNTAXE :
  11. C
  12. C RES = KPSO OBJ1 <'AXI' i> <'IMPR'> ;
  13. C
  14. C OBJ1 : Table DOMAINE
  15. C
  16. C AXI : Calcule en coordonee cylindrique 2D
  17. C i=2 axe de symetrie oy
  18. C
  19. C
  20. C************************************************************************
  21. IMPLICIT INTEGER(I-N)
  22. IMPLICIT REAL*8 (A-H,O-Z)
  23. -INC CCGEOME
  24.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC SMELEME
  28. -INC SMTABLE
  29. -INC SMCOORD
  30. -INC SMCHAML
  31. -INC SMCHPOI
  32. -INC SIZFFB
  33. CHARACTER*8 NOM0,CHAI,LISMO(1),TYPE,TYPC
  34. DATA LISMO/'IMPR '/
  35. C ***************************************************************
  36.  
  37. IMPR=0
  38. IAXI=0
  39. IF(IFOMOD.EQ.0)IAXI=2
  40.  
  41. CALL LITABS('DOMAINE ',MTABD,1,1,IRET)
  42. IF(IRET.EQ.0)THEN
  43. WRITE(6,*)' On attend une table de soustype DOMAINE'
  44. RETURN
  45. ENDIF
  46. TYPE=' '
  47. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  48. IF(TYPE.NE.'MAILLAGE')RETURN
  49.  
  50. 19 CONTINUE
  51. CALL LIRCHA(CHAI,0,IRET)
  52. IF(IRET.EQ.0)GO TO 20
  53. CALL OPTLI(IP,LISMO,CHAI,1)
  54. IF(IP.EQ.0)THEN
  55. WRITE(6,*)' On attend le mot cle IMPR '
  56. RETURN
  57. ENDIF
  58. IMPR=1
  59. GO TO 19
  60.  
  61. 20 CONTINUE
  62.  
  63.  
  64. C CREATION DE LA DIAGONALE
  65. CALL CRCHPE(MELEME,1,MCHELM)
  66. SEGACT MCHELM
  67. NBSOUS=IMACHE(/1)
  68.  
  69.  
  70. C
  71. C BOUCLE SUR LES TYPES D'ELEMENTS ET CALCUL
  72. C
  73. DO 1 KSOUS=1,NBSOUS
  74. MCHAML=ICHAML(KSOUS)
  75. SEGACT MCHAML
  76. MELVAL=IELVAL(1)
  77. SEGACT MELVAL*MOD
  78. IPT1=IMACHE(KSOUS)
  79. SEGACT IPT1
  80.  
  81. NP=IPT1.NUM(/1)
  82. NEL=IPT1.NUM(/2)
  83. C
  84. NOM0=NOMS(IPT1.ITYPEL)//' '
  85. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  86. SEGACT IZFFM*MOD
  87. IZHR=KZHR(1)
  88. SEGACT IZHR*MOD
  89. C
  90. NPG=FN(/2)
  91. NES=GR(/1)
  92.  
  93. IF(IMPR.NE.0)THEN
  94. WRITE(6,*)' SUB CADGSI : NES,NP,NPG,IDIM,NEL='
  95. & ,NES,NP,NPG,IDIM,NEL
  96. ENDIF
  97. C
  98. DO 10 K=1,NEL
  99. C
  100. NPGR=0
  101. IF(IAXI.NE.0)NPGR=NPG
  102. C
  103. DO 12 I=1,NP
  104. J=IPT1.NUM(I,K)
  105. DO 12 N=1,IDIM
  106. XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N)
  107. 12 CONTINUE
  108.  
  109. CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE)
  110.  
  111. IF(IMPR.NE.0)THEN
  112. WRITE(6,*)' SUB kpsoml : AIRE=',AIRE
  113. WRITE(6,*)' SUB kpsoml : LER '
  114. WRITE(6,1001)(IPT1.NUM(I,K),I=1,NP)
  115. WRITE(6,*)' SUB kpsoml : XYZ '
  116. WRITE(6,1002)((XYZ(N,I),N=1,2),I=1,NP)
  117. ENDIF
  118. C
  119. DO 3 J=1,NP
  120. SJ=0.D0
  121. DO 4 L=1,NPG
  122. 4 SJ=SJ+FN(J,L)*PGSQ(L)
  123. 3 VELCHE(J,K)=SJ
  124.  
  125. IF(IMPR.NE.0)THEN
  126. WRITE(6,*)' SUB CADGSI : CALCUL DE LA DIAGONALE'
  127. WRITE(6,1003)(K,VELCHE(I,K),I=1,NP)
  128. WRITE(6,*)' FIN DE CADGSI'
  129. ENDIF
  130. C
  131. 10 CONTINUE
  132. SEGDES MELVAL,MCHAML
  133. SEGDES IPT1
  134. SEGSUP IZFFM,IZHR
  135. 1 CONTINUE
  136.  
  137. SEGDES MCHELM
  138. CALL ECROBJ('MCHAML ',MCHELM)
  139. RETURN
  140. 1001 FORMAT(20(1X,I5))
  141. 1002 FORMAT(10(1X,1PE11.4))
  142. 1003 FORMAT(6(1X,I7,1X,1PE11.4))
  143. END
  144.  
  145.  
  146.  
  147.  
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  

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