Télécharger kfnref.eso

Retour à la liste

Numérotation des lignes :

  1. C KFNREF SOURCE GOUNAND 06/03/06 21:16:48 5319
  2. SUBROUTINE KFNREF(MYLRF,MYPG,
  3. $ FNPG,DFNPG,
  4. $ IMPR,IRET)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM : KFNREF
  9. C PROJET : Noyau linéaire NLIN
  10. C DESCRIPTION : Calcul des fonctions de forme et de leurs
  11. C dérivées aux points de Gauss sur l'élément
  12. C de référence.
  13. C Le but avoué de ce sous-programme est d'effectuer
  14. C toutes les opérations de pré-traitement sur un élément
  15. C de référence donné.
  16. C
  17. C LANGAGE : ESOPE
  18. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  19. C mél : gounand@semt2.smts.cea.fr
  20. C***********************************************************************
  21. C APPELES : CALPN, IVMAT, NI
  22. C APPELE PAR : KALPBG
  23. C***********************************************************************
  24. C ENTREES : MYLRF, MYPG
  25. C ENTREES/SORTIES : -
  26. C SORTIES : FNPG, DFNPG
  27. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  28. C***********************************************************************
  29. C VERSION : v1, 26/07/99, version initiale
  30. C HISTORIQUE : v1, 26/07/99, création
  31. C HISTORIQUE : v1.1 16/09/99, remaniement pour que la base polynômiale
  32. C puisse contenir des polynômes au lieu de
  33. C monômes exclusivement...
  34. C HISTORIQUE : v2, 10/05/00, modif. du segment ELREF
  35. C HISTORIQUE : v2.1 02/10/03 ajout d'astuces
  36. C HISTORIQUE :
  37. C***********************************************************************
  38. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  39. C en cas de modification de ce sous-programme afin de faciliter
  40. C la maintenance !
  41. C***********************************************************************
  42. -INC CCOPTIO
  43. -INC CCREEL
  44. CBEGININCLUDE SELREF
  45. SEGMENT ELREF
  46. CHARACTER*(LNNOM) NOMLRF
  47. CHARACTER*(LNFORM) FORME
  48. CHARACTER*(LNTYPL) TYPEL
  49. CHARACTER*(LNESP) ESPACE
  50. INTEGER DEGRE
  51. REAL*8 XCONOD(NDIMEL,NBNOD)
  52. INTEGER NPQUAF(NBDDL)
  53. INTEGER NUMCMP(NBDDL)
  54. INTEGER QUENOD(NBDDL)
  55. INTEGER ORDDER(NDIMEL,NBDDL)
  56. POINTEUR MBPOLY.POLYNS
  57. ENDSEGMENT
  58. SEGMENT ELREFS
  59. POINTEUR LISEL(0).ELREF
  60. ENDSEGMENT
  61. CENDINCLUDE SELREF
  62. POINTEUR MYLRF.ELREF
  63. CBEGININCLUDE SPOGAU
  64. SEGMENT POGAU
  65. CHARACTER*(LNNPG) NOMPG
  66. CHARACTER*(LNTPG) TYPMPG
  67. CHARACTER*(LNFPG) FORLPG
  68. INTEGER NORDPG
  69. REAL*8 XCOPG(NDLPG,NBPG)
  70. REAL*8 XPOPG(NBPG)
  71. ENDSEGMENT
  72. SEGMENT POGAUS
  73. POINTEUR LISPG(0).POGAU
  74. ENDSEGMENT
  75. CENDINCLUDE SPOGAU
  76. POINTEUR MYPG.POGAU
  77. CBEGININCLUDE SMCHAEL
  78. SEGMENT MCHAEL
  79. POINTEUR IMACHE(N1).MELEME
  80. POINTEUR ICHEVA(N1).MCHEVA
  81. ENDSEGMENT
  82. SEGMENT MCHEVA
  83. REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM)
  84. ENDSEGMENT
  85. SEGMENT LCHEVA
  86. POINTEUR LISCHE(NBCHE).MCHEVA
  87. ENDSEGMENT
  88. CENDINCLUDE SMCHAEL
  89. POINTEUR FNPG.MCHEVA
  90. POINTEUR DFNPG.MCHEVA
  91. -INC SMLENTI
  92. INTEGER JG
  93. POINTEUR IVTMP.MLENTI
  94. CBEGININCLUDE SMMREEL
  95. SEGMENT MMREEL
  96. REAL*8 MAT(JLIG,JCOL)
  97. ENDSEGMENT
  98. CENDINCLUDE SMMREEL
  99. POINTEUR PN.MMREEL
  100. POINTEUR PNM1.MMREEL
  101. *
  102. INTEGER IMPR,IRET
  103. *
  104. LOGICAL LLAHE,LCAST
  105. LOGICAL LCSTE,LLINE,LEGAL
  106. INTEGER NDFN
  107. REAL*8 DETPN
  108. *
  109. * Executable statements
  110. *
  111. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans kfnref'
  112. SEGACT MYLRF
  113. *
  114. LCAST=(MYLRF.NOMLRF.EQ.'H1D1PY5'.OR.MYLRF.NOMLRF.EQ.'H1D2PY13'
  115. $ .OR.MYLRF.NOMLRF.EQ.'H1D2PR15'.OR.MYLRF.NOMLRF.EQ.'H1D2CU20')
  116. *
  117. NDIML=MYLRF.ORDDER(/1)
  118. NBDDL=MYLRF.ORDDER(/2)
  119. LLAHE=(MYLRF.TYPEL.EQ.'LAGRANGE'.OR.MYLRF.TYPEL.EQ.'HERMITE')
  120. * On fait un cas particulier aux éléments de Lagrange
  121. * à un ddl : dans ce cas-la, la fonction de forme
  122. * est constante et sa dérivée est nulle
  123. LCSTE=(MYLRF.TYPEL.EQ.'LAGRANGE'.AND.NBDDL.EQ.1)
  124. * On fait un cas particulier aux éléments de Lagrange
  125. * linéaire (simplex) : dans ce cas-la, les dérivées des fonctions de
  126. * forme sont constantes
  127. LLINE=(MYLRF.TYPEL.EQ.'LAGRANGE'.AND.NBDDL.EQ.(NDIML+1))
  128. SEGDES MYLRF
  129. *
  130. * On repique les éléments dans SHAPE
  131. *
  132. IF (LCAST) THEN
  133. CALL SH2FNR(MYLRF,MYPG,
  134. $ FNPG,DFNPG,
  135. $ IMPR,IRET)
  136. IF (IRET.NE.0) GOTO 9999
  137. *
  138. * Astuce foireuse
  139. *
  140. ELSEIF (LCSTE) THEN
  141. NBLIG=1
  142. NBCOL=1
  143. N2LIG=1
  144. N2COL=1
  145. NBPOI=1
  146. NBELM=1
  147. SEGINI FNPG
  148. FNPG.VELCHE(1,1,1,1,1,1)=1.D0
  149. SEGDES FNPG
  150. NBLIG=1
  151. NBCOL=1
  152. N2LIG=1
  153. N2COL=NDIML
  154. NBPOI=1
  155. NBELM=1
  156. SEGINI DFNPG
  157. DO IDIML=1,NDIML
  158. DFNPG.VELCHE(1,1,1,IDIML,1,1)=0.D0
  159. ENDDO
  160. SEGDES DFNPG
  161. * Cas des éléments de Lagrange et Hermite
  162. ELSEIF (LLAHE) THEN
  163. *
  164. * Construisons la Matrice [PN] à l'aide de la base polynômiale :
  165. * et des coordonnées de noeuds d'approximation
  166. **
  167. CALL CALPN(MYLRF,
  168. $ PN,
  169. $ IMPR,IRET)
  170. IF (IRET.NE.0) GOTO 9999
  171. *
  172. * Inversons la Matrice [PN]
  173. *
  174. SEGACT PN
  175. SEGINI,PNM1=PN
  176. NDFN=PN.MAT(/1)
  177. JG=NDFN
  178. SEGINI IVTMP
  179. IIMPR=1
  180. CALL IVMAT(NDFN,PN.MAT,
  181. $ IVTMP.LECT,
  182. $ PNM1.MAT,DETPN,
  183. $ IIMPR,IRET)
  184. IF (IRET.NE.0) GOTO 9999
  185. SEGSUP IVTMP
  186. SEGSUP PN
  187. *
  188. * On peut maintenant calculer les valeurs des fonctions de forme
  189. * et leurs dérivées premières (par rapport aux coordonnées de l'espace
  190. * de référence) aux points de Gauss sur l'élément de référence
  191. *
  192. CALL NI(MYLRF,MYPG,PNM1,
  193. $ FNPG,DFNPG,
  194. $ IMPR,IRET)
  195. IF (IRET.NE.0) GOTO 9999
  196. SEGSUP PNM1
  197. ELSE
  198. WRITE(IOIMP,*) 'Le type d''élément ',MYLRF.TYPEL
  199. WRITE(IOIMP,*) 'n''est pas reconnu.'
  200. GOTO 9999
  201. ENDIF
  202. *
  203. * Astuce foireuse (mais on fait quand même des
  204. * vérifications)
  205. *
  206. IF (LLINE) THEN
  207. SEGACT DFNPG*MOD
  208. NBPOGO=DFNPG.VELCHE(/5)
  209. DO IDIML=1,NDIML
  210. DO IDDL=1,NBDDL
  211. VALDF=DFNPG.VELCHE(1,IDDL,1,IDIML,1,1)
  212. DO IPOGO=2,NBPOGO
  213. VALDF2=DFNPG.VELCHE(1,IDDL,1,IDIML,IPOGO,1)
  214. LEGAL=(ABS(VALDF2-VALDF).LE.100.D0*XZPREC)
  215. IF (.NOT.LEGAL) THEN
  216. WRITE(IOIMP,*) 'Houston, on a un probleme'
  217. * SEGPRT,DFNPG
  218. GOTO 9999
  219. ENDIF
  220. ENDDO
  221. ENDDO
  222. ENDDO
  223. NBLIG=1
  224. NBCOL=NBDDL
  225. N2LIG=1
  226. N2COL=NDIML
  227. NBPOI=1
  228. NBELM=1
  229. SEGADJ,DFNPG
  230. SEGDES DFNPG
  231. ENDIF
  232. *
  233. * Normal termination
  234. *
  235. IRET=0
  236. RETURN
  237. *
  238. * Error handling
  239. *
  240. 9999 CONTINUE
  241. IRET=1
  242. WRITE(IOIMP,*) 'An error was detected in subroutine kfnref'
  243. RETURN
  244. *
  245. * End of subroutine KFNREF
  246. *
  247. END
  248.  
  249.  
  250.  
  251.  
  252.  

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