Télécharger la plaquette Cast3M


fr en

Télécharger crepg.eso

Retour à la liste

Numérotation des lignes : 

crepg

  1. C CREPG     SOURCE    GOUNAND   21/06/02    21:15:33     11022          
  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.  
  39. -INC PPARAM
  40. -INC CCOPTIO
  41. -INC SMELEME
  42.       POINTEUR SFAVOL.MELEME
  43. *
  44. -INC TNLIN      
  45. *-INC SMCHAEL
  46.       POINTEUR JCOOR.MCHEVA
  47.       POINTEUR FFFAC.MCHEVA
  48.       POINTEUR DFFFAC.MCHEVA
  49.       POINTEUR JXCOPG.MCHEVA
  50.       POINTEUR JXPOPG.MCHEVA
  51.       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
  52. *-INC SELREF
  53.       POINTEUR LRFFAC.ELREF
  54. *-INC SFALRF
  55.       POINTEUR MYFALS.FALRFS
  56. *-INC SPOGAU
  57.       POINTEUR PGFAC.POGAU
  58. *-INC SFAPG
  59.       POINTEUR MYFPGS.FAPGS
  60. *-INC SIQUAF
  61.       POINTEUR IQUVOL.IQUAF
  62. *
  63.       INTEGER IMPR,IRET
  64. *
  65.       INTEGER IBELFV,IBNOQR,IDDLFA,IDIMQR,IPGFAC,ITYFAC
  66.       INTEGER NBELFV,       NDDLFA,NDIMQR,NPGFAC
  67.       REAL*8 VAL
  68.       CHARACTER*4 METING,MYDIS2
  69. *
  70. * Executable statements
  71. *
  72.       IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans crepg.eso'
  73. *
  74. * 1ere étape : on crée les degrés de liberté de la transformation
  75. *              géométrique (cf. mkcoor.eso)
  76. *
  77. *   On suppose que les transformations géométriques sur les
  78. *   éléments de référence sont LINEAIRES. On suppose également que
  79. *   le déterminant de la matrice jacobienne de la tranformation
  80. *   face de référence -> face d'un élément volumique de référence
  81. *   est CONSTANT => règle d'intégration numérique à 1 point de Gauss
  82.       MYDIS2='LINE'
  83. *
  84.       SEGACT IQUVOL
  85.       NDIMQR=IQUVOL.XCONQR(/1)
  86.       SEGACT SFAVOL
  87.       ITYFAC=SFAVOL.ITYPEL
  88.       CALL KEEF(ITYFAC,MYDIS2,
  89.      $     MYFALS,
  90.      $     LRFFAC,
  91.      $     IMPR,IRET)
  92.       IF (IRET.NE.0) GOTO 9999
  93.       SEGACT LRFFAC
  94.       NDDLFA=LRFFAC.NPQUAF(/1)
  95.       NBELFV=SFAVOL.NUM(/2)
  96.       NBLIG=1
  97.       NBCOL=NDDLFA
  98.       N2LIG=1
  99.       N2COL=NDIMQR
  100.       NBPOI=1
  101.       NBELM=NBELFV
  102.       SEGINI JCOOR
  103.       DO IBELFV=1,NBELFV
  104.          DO IDDLFA=1,NDDLFA
  105.             IBNOQR=SFAVOL.NUM(LRFFAC.NPQUAF(IDDLFA),IBELFV)
  106.             DO IDIMQR=1,NDIMQR
  107.                JCOOR.WELCHE(1,IDDLFA,1,IDIMQR,1,IBELFV)=
  108.      $              IQUVOL.XCONQR(IDIMQR,IBNOQR)
  109. *               write(ioimp,*) 'face=',IBELFV
  110. *               write(ioimp,*) 'coord espace=',IDIMQR
  111. *               write(ioimp,*) 'ddlfa=',IDDLFA
  112. *               write(ioimp,*)
  113. *     $              'VALEUR=',JCOOR.WELCHE(1,IDDLFA,1,IDIMQR,1,IBELFV)
  114. *               write(ioimp,*)  ' '
  115.             ENDDO
  116.          ENDDO
  117.       ENDDO
  118.       SEGDES SFAVOL
  119.       SEGDES IQUVOL
  120. *
  121. * 2ème étape : - on crée les fonctions de forme et leurs dérivées
  122. *                pour la transformation géométrie face -> volume
  123. *              - on récupère coordonnées et poids des points de
  124. *                Gauss pour la méthode METING sur la face de
  125. *                référence
  126. *              - pour chaque face de l'élément de référence volumique
  127. *                on construit les coordonnées des points de Gauss
  128. *                attenant à l'aide de la transformation géométrique
  129. *
  130.       CALL KEPG(ITYFAC,METING,
  131.      $     MYFPGS,
  132.      $     PGFAC,
  133.      $     IMPR,IRET)
  134.       IF (IRET.NE.0) GOTO 9999
  135. *
  136. * In KFNREF : SEGINI FFFAC
  137. * In KFNREF : SEGINI DFFFAC
  138. *
  139.       CALL KFNREF(LRFFAC,PGFAC,
  140.      $     FFFAC,DFFFAC,
  141.      $     IMPR,IRET)
  142.       IF (IRET.NE.0) GOTO 9999
  143.       SEGDES LRFFAC
  144. C      write(ioimp,*) 'Fonctions de formes sur la face'
  145. C      CALL PRCHVA(FFFAC,6,IRET)
  146.       IF (IRET.NE.0) GOTO 9999
  147.       SEGACT FFFAC
  148.       NPGFAC=FFFAC.WELCHE(/5)
  149.       NBLIG=1
  150.       NBCOL=1
  151.       N2LIG=1
  152.       N2COL=NDIMQR
  153.       NBPOI=NPGFAC
  154.       NBELM=NBELFV
  155.       SEGINI JXCOPG
  156.       DO IBELFV=1,NBELFV
  157.          DO IPGFAC=1,NPGFAC
  158.             DO IDIMQR=1,NDIMQR
  159.                DO IDDLFA=1,NDDLFA
  160.                   VAL=JCOOR.WELCHE(1,IDDLFA,1,IDIMQR,1,IBELFV)*
  161.      $                  FFFAC.WELCHE(1,IDDLFA,1,1,IPGFAC,1)
  162.                   JXCOPG.WELCHE(1,1,1,IDIMQR,IPGFAC,IBELFV)=
  163.      $                 JXCOPG.WELCHE(1,1,1,IDIMQR,IPGFAC,IBELFV)+
  164.      $                 VAL
  165.                ENDDO
  166. *               write(ioimp,*) 'face=',IBELFV
  167. *               write(ioimp,*) 'no point gauss=',IPGFAC
  168. *               write(ioimp,*) 'coord espace=',IDIMQR
  169. *               write(ioimp,*)
  170. *     $              'VALEUR=',JXCOPG.WELCHE(1,1,1,IDIMQR,IPGFAC,IBELFV)
  171. *               write(ioimp,*)  ' '
  172.             ENDDO
  173.          ENDDO
  174.       ENDDO
  175.       SEGSUP JCOOR
  176.       SEGDES JXCOPG
  177. *      SEGDES FFFAC
  178.       SEGSUP FFFAC
  179.       SEGSUP DFFFAC
  180. *
  181. * 3ème étape : Poids
  182. *
  183.       SEGACT PGFAC
  184.       NBLIG=1
  185.       NBCOL=1
  186.       N2LIG=1
  187.       N2COL=1
  188.       NBPOI=NPGFAC
  189.       NBELM=1
  190.       SEGINI JXPOPG
  191.       DO IPGFAC=1,NPGFAC
  192.          JXPOPG.WELCHE(1,1,1,1,IPGFAC,1)=
  193.      $           PGFAC.XPOPG(IPGFAC)
  194. *!     $           JDTJAF.WELCHE(1,1,1,1,IPGFAC,IBELFV)*
  195. *!     $           PGFAC.XPOPG(IPGFAC)
  196.       ENDDO
  197.       SEGDES JXPOPG
  198.       SEGDES PGFAC
  199. *
  200. * Normal termination
  201. *
  202.       IRET=0
  203.       RETURN
  204. *
  205. * Format handling
  206. *
  207. *
  208. * Error handling
  209. *
  210.  9999 CONTINUE
  211.       IRET=1
  212.       WRITE(IOIMP,*) 'An error was detected in subroutine crepg'
  213.       RETURN
  214. *
  215. * End of subroutine CREPG
  216. *
  217.       END
  218.  
  219.  
  220.  
  221.  

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