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 PPARAM
  43. -INC CCOPTIO
  44. -INC CCREEL
  45. CBEGININCLUDE SELREF
  46. SEGMENT ELREF
  47. CHARACTER*(LNNOM) NOMLRF
  48. CHARACTER*(LNFORM) FORME
  49. CHARACTER*(LNTYPL) TYPEL
  50. CHARACTER*(LNESP) ESPACE
  51. INTEGER DEGRE
  52. REAL*8 XCONOD(NDIMEL,NBNOD)
  53. INTEGER NPQUAF(NBDDL)
  54. INTEGER NUMCMP(NBDDL)
  55. INTEGER QUENOD(NBDDL)
  56. INTEGER ORDDER(NDIMEL,NBDDL)
  57. POINTEUR MBPOLY.POLYNS
  58. ENDSEGMENT
  59. SEGMENT ELREFS
  60. POINTEUR LISEL(0).ELREF
  61. ENDSEGMENT
  62. CENDINCLUDE SELREF
  63. POINTEUR MYLRF.ELREF
  64. CBEGININCLUDE SPOGAU
  65. SEGMENT POGAU
  66. CHARACTER*(LNNPG) NOMPG
  67. CHARACTER*(LNTPG) TYPMPG
  68. CHARACTER*(LNFPG) FORLPG
  69. INTEGER NORDPG
  70. REAL*8 XCOPG(NDLPG,NBPG)
  71. REAL*8 XPOPG(NBPG)
  72. ENDSEGMENT
  73. SEGMENT POGAUS
  74. POINTEUR LISPG(0).POGAU
  75. ENDSEGMENT
  76. CENDINCLUDE SPOGAU
  77. POINTEUR MYPG.POGAU
  78. CBEGININCLUDE SMCHAEL
  79. SEGMENT MCHAEL
  80. POINTEUR IMACHE(N1).MELEME
  81. POINTEUR ICHEVA(N1).MCHEVA
  82. ENDSEGMENT
  83. SEGMENT MCHEVA
  84. REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM)
  85. ENDSEGMENT
  86. SEGMENT LCHEVA
  87. POINTEUR LISCHE(NBCHE).MCHEVA
  88. ENDSEGMENT
  89. CENDINCLUDE SMCHAEL
  90. POINTEUR FNPG.MCHEVA
  91. POINTEUR DFNPG.MCHEVA
  92. -INC SMLENTI
  93. INTEGER JG
  94. POINTEUR IVTMP.MLENTI
  95. CBEGININCLUDE SMMREEL
  96. SEGMENT MMREEL
  97. REAL*8 MAT(JLIG,JCOL)
  98. ENDSEGMENT
  99. CENDINCLUDE SMMREEL
  100. POINTEUR PN.MMREEL
  101. POINTEUR PNM1.MMREEL
  102. *
  103. INTEGER IMPR,IRET
  104. *
  105. LOGICAL LLAHE,LCAST
  106. LOGICAL LCSTE,LLINE,LEGAL
  107. INTEGER NDFN
  108. REAL*8 DETPN
  109. *
  110. * Executable statements
  111. *
  112. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans kfnref'
  113. SEGACT MYLRF
  114. *
  115. LCAST=(MYLRF.NOMLRF.EQ.'H1D1PY5'.OR.MYLRF.NOMLRF.EQ.'H1D2PY13'
  116. $ .OR.MYLRF.NOMLRF.EQ.'H1D2PR15'.OR.MYLRF.NOMLRF.EQ.'H1D2CU20')
  117. *
  118. NDIML=MYLRF.ORDDER(/1)
  119. NBDDL=MYLRF.ORDDER(/2)
  120. LLAHE=(MYLRF.TYPEL.EQ.'LAGRANGE'.OR.MYLRF.TYPEL.EQ.'HERMITE')
  121. * On fait un cas particulier aux éléments de Lagrange
  122. * à un ddl : dans ce cas-la, la fonction de forme
  123. * est constante et sa dérivée est nulle
  124. LCSTE=(MYLRF.TYPEL.EQ.'LAGRANGE'.AND.NBDDL.EQ.1)
  125. * On fait un cas particulier aux éléments de Lagrange
  126. * linéaire (simplex) : dans ce cas-la, les dérivées des fonctions de
  127. * forme sont constantes
  128. LLINE=(MYLRF.TYPEL.EQ.'LAGRANGE'.AND.NBDDL.EQ.(NDIML+1))
  129. SEGDES MYLRF
  130. *
  131. * On repique les éléments dans SHAPE
  132. *
  133. IF (LCAST) THEN
  134. CALL SH2FNR(MYLRF,MYPG,
  135. $ FNPG,DFNPG,
  136. $ IMPR,IRET)
  137. IF (IRET.NE.0) GOTO 9999
  138. *
  139. * Astuce foireuse
  140. *
  141. ELSEIF (LCSTE) THEN
  142. NBLIG=1
  143. NBCOL=1
  144. N2LIG=1
  145. N2COL=1
  146. NBPOI=1
  147. NBELM=1
  148. SEGINI FNPG
  149. FNPG.VELCHE(1,1,1,1,1,1)=1.D0
  150. SEGDES FNPG
  151. NBLIG=1
  152. NBCOL=1
  153. N2LIG=1
  154. N2COL=NDIML
  155. NBPOI=1
  156. NBELM=1
  157. SEGINI DFNPG
  158. DO IDIML=1,NDIML
  159. DFNPG.VELCHE(1,1,1,IDIML,1,1)=0.D0
  160. ENDDO
  161. SEGDES DFNPG
  162. * Cas des éléments de Lagrange et Hermite
  163. ELSEIF (LLAHE) THEN
  164. *
  165. * Construisons la Matrice [PN] à l'aide de la base polynômiale :
  166. * et des coordonnées de noeuds d'approximation
  167. **
  168. CALL CALPN(MYLRF,
  169. $ PN,
  170. $ IMPR,IRET)
  171. IF (IRET.NE.0) GOTO 9999
  172. *
  173. * Inversons la Matrice [PN]
  174. *
  175. SEGACT PN
  176. SEGINI,PNM1=PN
  177. NDFN=PN.MAT(/1)
  178. JG=NDFN
  179. SEGINI IVTMP
  180. IIMPR=1
  181. CALL IVMAT(NDFN,PN.MAT,
  182. $ IVTMP.LECT,
  183. $ PNM1.MAT,DETPN,
  184. $ IIMPR,IRET)
  185. IF (IRET.NE.0) GOTO 9999
  186. SEGSUP IVTMP
  187. SEGSUP PN
  188. *
  189. * On peut maintenant calculer les valeurs des fonctions de forme
  190. * et leurs dérivées premières (par rapport aux coordonnées de l'espace
  191. * de référence) aux points de Gauss sur l'élément de référence
  192. *
  193. CALL NI(MYLRF,MYPG,PNM1,
  194. $ FNPG,DFNPG,
  195. $ IMPR,IRET)
  196. IF (IRET.NE.0) GOTO 9999
  197. SEGSUP PNM1
  198. ELSE
  199. WRITE(IOIMP,*) 'Le type d''élément ',MYLRF.TYPEL
  200. WRITE(IOIMP,*) 'n''est pas reconnu.'
  201. GOTO 9999
  202. ENDIF
  203. *
  204. * Astuce foireuse (mais on fait quand même des
  205. * vérifications)
  206. *
  207. IF (LLINE) THEN
  208. SEGACT DFNPG*MOD
  209. NBPOGO=DFNPG.VELCHE(/5)
  210. DO IDIML=1,NDIML
  211. DO IDDL=1,NBDDL
  212. VALDF=DFNPG.VELCHE(1,IDDL,1,IDIML,1,1)
  213. DO IPOGO=2,NBPOGO
  214. VALDF2=DFNPG.VELCHE(1,IDDL,1,IDIML,IPOGO,1)
  215. LEGAL=(ABS(VALDF2-VALDF).LE.100.D0*XZPREC)
  216. IF (.NOT.LEGAL) THEN
  217. WRITE(IOIMP,*) 'Houston, on a un probleme'
  218. * SEGPRT,DFNPG
  219. GOTO 9999
  220. ENDIF
  221. ENDDO
  222. ENDDO
  223. ENDDO
  224. NBLIG=1
  225. NBCOL=NBDDL
  226. N2LIG=1
  227. N2COL=NDIML
  228. NBPOI=1
  229. NBELM=1
  230. SEGADJ,DFNPG
  231. SEGDES DFNPG
  232. ENDIF
  233. *
  234. * Normal termination
  235. *
  236. IRET=0
  237. RETURN
  238. *
  239. * Error handling
  240. *
  241. 9999 CONTINUE
  242. IRET=1
  243. WRITE(IOIMP,*) 'An error was detected in subroutine kfnref'
  244. RETURN
  245. *
  246. * End of subroutine KFNREF
  247. *
  248. END
  249.  
  250.  
  251.  
  252.  
  253.  

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