Télécharger kfnrff.eso

Retour à la liste

Numérotation des lignes :

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

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