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

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