Télécharger kpsoml.eso

Retour à la liste

Numérotation des lignes :

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

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