Télécharger hrsi.eso

Retour à la liste

Numérotation des lignes :

  1. C HRSI SOURCE PV 16/11/17 21:59:39 9180
  2. SUBROUTINE HRSI
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C************************************************************************
  6. C I OBJET
  7. C ----------
  8. C CALCUL DES HR (GRADIENTS FF) ELEMENTAIRES SOUS INTEGRES
  9. C
  10. C
  11. C II SYNTAXE
  12. C ___________
  13. C
  14. C RES = HRSI OBJ1 <'AXI' i > <'IMPR'>
  15. C
  16. C OBJ1 : Objet MAILLAGE
  17. C AXI DISCRETISATION CORDONNEES CYLINDRIQUE (2D)
  18. C i=1 AXE DE SYMETRIE y=0
  19. C i=2 AXE DE SYMETRIE x=0
  20. C IMPR : impressions de controle
  21.  
  22. C RES : Resultat objet de type MATESI
  23. C************************************************************************
  24. C
  25. -INC CCGEOME
  26.  
  27. -INC PPARAM
  28. -INC CCOPTIO
  29. -INC SMTABLE
  30. POINTEUR MTABD.MTABLE
  31. -INC SIZFFB
  32. -INC SMCOORD
  33. -INC SMELEME
  34. POINTEUR MELEMZ.MELEME
  35. CHARACTER*8 NMD,NOM0,NOM,TYPE,LISTM(1)
  36. DIMENSION HRT(24),RPGJ(9),XYZI(24)
  37. PARAMETER (NTB=1)
  38. CHARACTER*8 LTAB(NTB)
  39. DIMENSION KTAB(NTB)
  40. DATA LTAB/'DOMAINE '/
  41. DATA LISTM/'IMPR '/
  42. C*****************************************************************************
  43.  
  44. CALL LITABS(LTAB,KTAB,NTB,1,IRET)
  45. IF (IERR.NE.0) RETURN
  46. MTABD=KTAB(1)
  47.  
  48. IAXI=0
  49. IF(IFOMOD.EQ.0)IAXI=2
  50. IMPAP=0
  51. 1 CONTINUE
  52. CALL LIRCHA(NOM,0,IRET)
  53. IF(IRET.NE.0)THEN
  54. CALL OPTLI(IP,LISTM,NOM,1)
  55. IF(IP.EQ.0)THEN
  56. WRITE(6,*)' On attend le mot cle IMPR'
  57. C Il manque la donnée d'un mot clé.
  58. CALL ERREUR(498)
  59. RETURN
  60. ELSE
  61. IMPAP=1
  62. GO TO 1
  63. ENDIF
  64. ENDIF
  65. C
  66. TYPE='MAILLAGE'
  67. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEMZ)
  68. CALL ACMO(MTABD,'SOMMET',TYPE,MELES1)
  69. CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  70. IF (IERR.NE.0) RETURN
  71.  
  72. SEGACT MELEMZ
  73. NBSOUS=MELEMZ.LISOUS(/1)
  74. IF(NBSOUS.EQ.0)NBSOUS=1
  75. C
  76. C ON CREE L OBJET MATRIK
  77. C
  78. NRIGE=7
  79. NKID =9
  80. NKMT =7
  81. NMATRI=1
  82. SEGINI MATRIK
  83. IRIGEL(1,1)=MELEMZ
  84. IRIGEL(2,1)=MELEMZ
  85. IRIGEL(7,1)=1
  86. NBOP=0
  87. NBELC=0
  88. NBME=1
  89. IF(IAXI.NE.0)NBME=2
  90. SEGINI IMATRI
  91. IRIGEL(4,1)=IMATRI
  92. C KGEOS=MELES1
  93. KSPGP=MELES1
  94. C KGEOC=MELEMC
  95. KSPGD=MELEMC
  96.  
  97. C
  98. C BOUCLE SUR LES TYPES D'ELEMENTS ET CALCUL
  99. C
  100. DO 81 KSOUS=1,NBSOUS
  101. IF(NBSOUS.EQ.1)IPT1=MELEMZ
  102. IF(NBSOUS.NE.1)IPT1=MELEMZ.LISOUS(KSOUS)
  103. SEGACT IPT1
  104.  
  105. NOM0=NOMS(IPT1.ITYPEL)//' '
  106. C
  107. CALL KALPBG(NOM0,'FONFORM0',IZFFM)
  108. SEGACT IZFFM*MOD
  109. IZHR=KZHR(1)
  110. SEGACT IZHR*MOD
  111.  
  112. NBEL=IPT1.NUM(/2)
  113. IF(IAXI.NE.0)THEN
  114. NP=1
  115. MP=1
  116. SEGINI IPM1
  117. LIZAFM(KSOUS,2)=IPM1
  118. ENDIF
  119. NP=IPT1.NUM(/1)
  120. NES=GR(/1)
  121. NPG=GR(/3)
  122. MP=NES
  123. IESP=MP
  124. SEGINI IZAFM
  125. C
  126. SEGACT IPT1
  127. LIZAFM(KSOUS,1)=IZAFM
  128.  
  129. IF(IMPAP.NE.0)THEN
  130. WRITE(6,*)' CREATION SEGMENT MATRIK '
  131. WRITE(6,*)' FONCTIONS DE FORME '
  132. WRITE(6,1002)((FN(MM,II),MM=1,NP),II=1,NPG)
  133. WRITE(6,*)' FONCTIONS DE FORME '
  134. WRITE(6,1002)((GR(1,MM,II),MM=1,NP),II=1,NPG)
  135. WRITE(6,1002)((GR(2,MM,II),MM=1,NP),II=1,NPG)
  136. ENDIF
  137.  
  138. DO 8 K=1,NBEL
  139. IJ=1
  140. DO 9 I=1,NP
  141. J=IPT1.NUM(I,K)
  142. DO 9 N=1,IESP
  143. XYZI(IJ )=XCOOR((J-1)*(IDIM+1)+N)
  144. IJ=IJ+1
  145. 9 CONTINUE
  146. C
  147. CALL CALJBC(FN,GR,PG,XYZI,HRT,PGSQ,RPGJ,NES,
  148. *IESP,NP,NPG,IAXI,AIRE)
  149. IH=0
  150. DO 98 I=1,NP
  151. DO 98 N=1,IESP
  152. IH=IH+1
  153. AM(K,I,N)=HRT(IH)
  154. 98 CONTINUE
  155. IF(IAXI.NE.0)IPM1.AM(K,1,1)=RPGJ(1)
  156.  
  157.  
  158. 8 CONTINUE
  159. IF(IPT1.NE.MELEMZ)SEGDES IPT1
  160. SEGDES IZAFM
  161. IF(IAXI.NE.0)SEGDES IPM1
  162. SEGSUP IZFFM,IZHR
  163. 81 CONTINUE
  164. SEGDES MELEMZ,IMATRI
  165. 32 CONTINUE
  166. SEGDES MATRIK
  167. CALL ECROBJ('MATRIK',MATRIK)
  168. RETURN
  169. 1002 FORMAT(10(1X,1PE11.4))
  170. END
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  

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