Télécharger crepg.eso

Retour à la liste

Numérotation des lignes :

  1. C CREPG SOURCE GOUNAND 06/08/04 21:15:11 5520
  2. SUBROUTINE CREPG(IQUVOL,SFAVOL,METING,MYFALS,MYFPGS,
  3. $ JXCOPG,JXPOPG,
  4. $ IMPR,IRET)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM : CREPG
  9. C DESCRIPTION : Création des points de Gauss
  10. C pour des faces de l'élément de référence.
  11. C
  12. C
  13. C LANGAGE : ESOPE
  14. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  15. C mél : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELES :
  18. C APPELES (E/S) :
  19. C APPELES (BLAS) :
  20. C APPELES (CALCUL) :
  21. C APPELE PAR :
  22. C***********************************************************************
  23. C SYNTAXE GIBIANE :
  24. C ENTREES :
  25. C ENTREES/SORTIES :
  26. C SORTIES :
  27. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  28. C***********************************************************************
  29. C VERSION : v1, 20/12/2002, version initiale
  30. C HISTORIQUE : v1, 20/12/2002, création
  31. C HISTORIQUE :
  32. C HISTORIQUE :
  33. C***********************************************************************
  34. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  35. C en cas de modification de ce sous-programme afin de faciliter
  36. C la maintenance !
  37. C***********************************************************************
  38. -INC CCOPTIO
  39. -INC SMELEME
  40. POINTEUR SFAVOL.MELEME
  41. *
  42. CBEGININCLUDE SMCHAEL
  43. SEGMENT MCHAEL
  44. POINTEUR IMACHE(N1).MELEME
  45. POINTEUR ICHEVA(N1).MCHEVA
  46. ENDSEGMENT
  47. SEGMENT MCHEVA
  48. REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM)
  49. ENDSEGMENT
  50. SEGMENT LCHEVA
  51. POINTEUR LISCHE(NBCHE).MCHEVA
  52. ENDSEGMENT
  53. CENDINCLUDE SMCHAEL
  54. POINTEUR JCOOR.MCHEVA
  55. POINTEUR FFFAC.MCHEVA
  56. POINTEUR DFFFAC.MCHEVA
  57. POINTEUR JXCOPG.MCHEVA
  58. POINTEUR JXPOPG.MCHEVA
  59. INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
  60. CBEGININCLUDE SELREF
  61. SEGMENT ELREF
  62. CHARACTER*(LNNOM) NOMLRF
  63. CHARACTER*(LNFORM) FORME
  64. CHARACTER*(LNTYPL) TYPEL
  65. CHARACTER*(LNESP) ESPACE
  66. INTEGER DEGRE
  67. REAL*8 XCONOD(NDIMEL,NBNOD)
  68. INTEGER NPQUAF(NBDDL)
  69. INTEGER NUMCMP(NBDDL)
  70. INTEGER QUENOD(NBDDL)
  71. INTEGER ORDDER(NDIMEL,NBDDL)
  72. POINTEUR MBPOLY.POLYNS
  73. ENDSEGMENT
  74. SEGMENT ELREFS
  75. POINTEUR LISEL(0).ELREF
  76. ENDSEGMENT
  77. CENDINCLUDE SELREF
  78. POINTEUR LRFFAC.ELREF
  79. CBEGININCLUDE SFALRF
  80. SEGMENT FALRF
  81. CHARACTER*(LNNFA) NOMFA
  82. INTEGER NUQUAF(NBLRF)
  83. POINTEUR ELEMF(NBLRF).ELREF
  84. ENDSEGMENT
  85. SEGMENT FALRFS
  86. POINTEUR LISFA(0).FALRF
  87. ENDSEGMENT
  88. CENDINCLUDE SFALRF
  89. POINTEUR MYFALS.FALRFS
  90. CBEGININCLUDE SPOGAU
  91. SEGMENT POGAU
  92. CHARACTER*(LNNPG) NOMPG
  93. CHARACTER*(LNTPG) TYPMPG
  94. CHARACTER*(LNFPG) FORLPG
  95. INTEGER NORDPG
  96. REAL*8 XCOPG(NDLPG,NBPG)
  97. REAL*8 XPOPG(NBPG)
  98. ENDSEGMENT
  99. SEGMENT POGAUS
  100. POINTEUR LISPG(0).POGAU
  101. ENDSEGMENT
  102. CENDINCLUDE SPOGAU
  103. POINTEUR PGFAC.POGAU
  104. CBEGININCLUDE SFAPG
  105. SEGMENT FAPG
  106. CHARACTER*(LNNFAP) NOMFAP
  107. INTEGER NBQUAF(NBMPG)
  108. POINTEUR MPOGAU(NBMPG).POGAU
  109. ENDSEGMENT
  110. SEGMENT FAPGS
  111. POINTEUR LISFPG(0).FAPG
  112. ENDSEGMENT
  113. CENDINCLUDE SFAPG
  114. POINTEUR MYFPGS.FAPGS
  115. CBEGININCLUDE SIQUAF
  116. SEGMENT IQUAF
  117. INTEGER NUMQUF
  118. REAL*8 XCONQR(NDIMQR,NBNOQR)
  119. INTEGER NUCENT
  120. POINTEUR LFACE.MELEME
  121. ENDSEGMENT
  122. SEGMENT IQUAFS
  123. POINTEUR LISQRF(NBQRF).IQUAF
  124. ENDSEGMENT
  125. CENDINCLUDE SIQUAF
  126. POINTEUR IQUVOL.IQUAF
  127. *
  128. INTEGER IMPR,IRET
  129. *
  130. INTEGER IBELFV,IBNOQR,IDDLFA,IDIMQR,IPGFAC,ITYFAC
  131. INTEGER NBELFV, NDDLFA,NDIMQR,NPGFAC
  132. REAL*8 VAL
  133. CHARACTER*4 METING,MYDIS2
  134. *
  135. * Executable statements
  136. *
  137. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans crepg.eso'
  138. *
  139. * 1ere étape : on crée les degrés de liberté de la transformation
  140. * géométrique (cf. mkcoor.eso)
  141. *
  142. * On suppose que les transformations géométriques sur les
  143. * éléments de référence sont LINEAIRES. On suppose également que
  144. * le déterminant de la matrice jacobienne de la tranformation
  145. * face de référence -> face d'un élément volumique de référence
  146. * est CONSTANT => règle d'intégration numérique à 1 point de Gauss
  147. MYDIS2='LINE'
  148. *
  149. SEGACT IQUVOL
  150. NDIMQR=IQUVOL.XCONQR(/1)
  151. SEGACT SFAVOL
  152. ITYFAC=SFAVOL.ITYPEL
  153. CALL KEEF(ITYFAC,MYDIS2,
  154. $ MYFALS,
  155. $ LRFFAC,
  156. $ IMPR,IRET)
  157. IF (IRET.NE.0) GOTO 9999
  158. SEGACT LRFFAC
  159. NDDLFA=LRFFAC.NPQUAF(/1)
  160. NBELFV=SFAVOL.NUM(/2)
  161. NBLIG=1
  162. NBCOL=NDDLFA
  163. N2LIG=1
  164. N2COL=NDIMQR
  165. NBPOI=1
  166. NBELM=NBELFV
  167. SEGINI JCOOR
  168. DO IBELFV=1,NBELFV
  169. DO IDDLFA=1,NDDLFA
  170. IBNOQR=SFAVOL.NUM(LRFFAC.NPQUAF(IDDLFA),IBELFV)
  171. DO IDIMQR=1,NDIMQR
  172. JCOOR.VELCHE(1,IDDLFA,1,IDIMQR,1,IBELFV)=
  173. $ IQUVOL.XCONQR(IDIMQR,IBNOQR)
  174. * write(ioimp,*) 'face=',IBELFV
  175. * write(ioimp,*) 'coord espace=',IDIMQR
  176. * write(ioimp,*) 'ddlfa=',IDDLFA
  177. * write(ioimp,*)
  178. * $ 'VALEUR=',JCOOR.VELCHE(1,IDDLFA,1,IDIMQR,1,IBELFV)
  179. * write(ioimp,*) ' '
  180. ENDDO
  181. ENDDO
  182. ENDDO
  183. SEGDES SFAVOL
  184. SEGDES IQUVOL
  185. *
  186. * 2ème étape : - on crée les fonctions de forme et leurs dérivées
  187. * pour la transformation géométrie face -> volume
  188. * - on récupère coordonnées et poids des points de
  189. * Gauss pour la méthode METING sur la face de
  190. * référence
  191. * - pour chaque face de l'élément de référence volumique
  192. * on construit les coordonnées des points de Gauss
  193. * attenant à l'aide de la transformation géométrique
  194. *
  195. CALL KEPG(ITYFAC,METING,
  196. $ MYFPGS,
  197. $ PGFAC,
  198. $ IMPR,IRET)
  199. IF (IRET.NE.0) GOTO 9999
  200. *
  201. * In KFNREF : SEGINI FFFAC
  202. * In KFNREF : SEGINI DFFFAC
  203. *
  204. CALL KFNREF(LRFFAC,PGFAC,
  205. $ FFFAC,DFFFAC,
  206. $ IMPR,IRET)
  207. IF (IRET.NE.0) GOTO 9999
  208. SEGDES LRFFAC
  209. C write(ioimp,*) 'Fonctions de formes sur la face'
  210. C CALL PRCHVA(FFFAC,6,IRET)
  211. IF (IRET.NE.0) GOTO 9999
  212. SEGACT FFFAC
  213. NPGFAC=FFFAC.VELCHE(/5)
  214. NBLIG=1
  215. NBCOL=1
  216. N2LIG=1
  217. N2COL=NDIMQR
  218. NBPOI=NPGFAC
  219. NBELM=NBELFV
  220. SEGINI JXCOPG
  221. DO IBELFV=1,NBELFV
  222. DO IPGFAC=1,NPGFAC
  223. DO IDIMQR=1,NDIMQR
  224. DO IDDLFA=1,NDDLFA
  225. VAL=JCOOR.VELCHE(1,IDDLFA,1,IDIMQR,1,IBELFV)*
  226. $ FFFAC.VELCHE(1,IDDLFA,1,1,IPGFAC,1)
  227. JXCOPG.VELCHE(1,1,1,IDIMQR,IPGFAC,IBELFV)=
  228. $ JXCOPG.VELCHE(1,1,1,IDIMQR,IPGFAC,IBELFV)+
  229. $ VAL
  230. ENDDO
  231. * write(ioimp,*) 'face=',IBELFV
  232. * write(ioimp,*) 'no point gauss=',IPGFAC
  233. * write(ioimp,*) 'coord espace=',IDIMQR
  234. * write(ioimp,*)
  235. * $ 'VALEUR=',JXCOPG.VELCHE(1,1,1,IDIMQR,IPGFAC,IBELFV)
  236. * write(ioimp,*) ' '
  237. ENDDO
  238. ENDDO
  239. ENDDO
  240. SEGSUP JCOOR
  241. SEGDES JXCOPG
  242. * SEGDES FFFAC
  243. SEGSUP FFFAC
  244. SEGSUP DFFFAC
  245. *
  246. * 3ème étape : Poids
  247. *
  248. SEGACT PGFAC
  249. NBLIG=1
  250. NBCOL=1
  251. N2LIG=1
  252. N2COL=1
  253. NBPOI=NPGFAC
  254. NBELM=1
  255. SEGINI JXPOPG
  256. DO IPGFAC=1,NPGFAC
  257. JXPOPG.VELCHE(1,1,1,1,IPGFAC,1)=
  258. $ PGFAC.XPOPG(IPGFAC)
  259. *! $ JDTJAF.VELCHE(1,1,1,1,IPGFAC,IBELFV)*
  260. *! $ PGFAC.XPOPG(IPGFAC)
  261. ENDDO
  262. SEGDES JXPOPG
  263. SEGDES PGFAC
  264. *
  265. * Normal termination
  266. *
  267. IRET=0
  268. RETURN
  269. *
  270. * Format handling
  271. *
  272. *
  273. * Error handling
  274. *
  275. 9999 CONTINUE
  276. IRET=1
  277. WRITE(IOIMP,*) 'An error was detected in subroutine crepg'
  278. RETURN
  279. *
  280. * End of subroutine CREPG
  281. *
  282. END
  283.  
  284.  
  285.  

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