Télécharger hrsi.eso

Retour à la liste

Numérotation des lignes :

  1. C HRSI SOURCE PV 20/09/28 21:15:13 10727
  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 I=1,NP
  141. J=IPT1.NUM(I,K)
  142. DO N=1,IESP
  143. XYZI(IJ )=XCOOR((J-1)*(IDIM+1)+N)
  144. IJ=IJ+1
  145. ENDDO
  146. ENDDO
  147. C
  148. CALL CALJBC(FN,GR,PG,XYZI,HRT,PGSQ,RPGJ,NES,
  149. *IESP,NP,NPG,IAXI,AIRE)
  150. IH=0
  151. DO I=1,NP
  152. DO N=1,IESP
  153. IH=IH+1
  154. AM(K,I,N)=HRT(IH)
  155. ENDDO
  156. ENDDO
  157. IF(IAXI.NE.0)IPM1.AM(K,1,1)=RPGJ(1)
  158.  
  159.  
  160. 8 CONTINUE
  161. IF(IPT1.NE.MELEMZ)SEGDES IPT1
  162. SEGDES IZAFM
  163. IF(IAXI.NE.0)SEGDES IPM1
  164. SEGSUP IZFFM,IZHR
  165. 81 CONTINUE
  166. SEGDES MELEMZ,IMATRI
  167. 32 CONTINUE
  168. SEGDES MATRIK
  169. CALL ECROBJ('MATRIK',MATRIK)
  170. RETURN
  171. 1002 FORMAT(10(1X,1PE11.4))
  172. END
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  

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