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

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