Télécharger geolf2.eso

Retour à la liste

Numérotation des lignes :

  1. C GEOLF2 SOURCE GOUNAND 06/08/04 21:15:55 5520
  2. SUBROUTINE GEOLF2(LRFVOL,IQUVOL,SFAVOL,
  3. $ MYDISC,METING,MYFALS,MYFPGS,
  4. $ JCOOR,SSFACT,NBELEF,
  5. $ JMAJA2,JMIJA2,JDTJA2,LERJ2,
  6. $ IMPR,IRET)
  7. IMPLICIT REAL*8 (A-H,O-Z)
  8. IMPLICIT INTEGER (I-N)
  9. C***********************************************************************
  10. C NOM : GEOLF2
  11. C PROJET : Noyau linéaire NLIN
  12. C DESCRIPTION :
  13. C
  14. C LANGAGE : ESOPE
  15. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  16. C mél : gounand@semt2.smts.cea.fr
  17. C***********************************************************************
  18. C APPELES :
  19. C APPELE PAR :
  20. C***********************************************************************
  21. C ENTREES :
  22. C ENTREES/SORTIES : -
  23. C SORTIES :
  24. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  25. C***********************************************************************
  26. C VERSION : v1, 30/07/03, version initiale
  27. C HISTORIQUE : v1, 30/07/03, création
  28. C HISTORIQUE :
  29. C HISTORIQUE :
  30. C***********************************************************************
  31. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  32. C en cas de modification de ce sous-programme afin de faciliter
  33. C la maintenance !
  34. C***********************************************************************
  35. -INC PPARAM
  36. -INC CCOPTIO
  37. -INC SMELEME
  38. POINTEUR SFAVOL.MELEME
  39. -INC SMLENTI
  40. POINTEUR KPQVOL.MLENTI
  41. *
  42. CBEGININCLUDE SFACTIV
  43. SEGMENT FACTIV
  44. POINTEUR IFACTI(NBSOUV).SFACTI
  45. ENDSEGMENT
  46. SEGMENT SFACTI
  47. POINTEUR ISFACT(NBSOFV).SSFACT
  48. ENDSEGMENT
  49. SEGMENT SSFACT
  50. LOGICAL LFACTI(NBELFV,NBELEV)
  51. ENDSEGMENT
  52. CENDINCLUDE SFACTIV
  53. CBEGININCLUDE SMCHAEL
  54. SEGMENT MCHAEL
  55. POINTEUR IMACHE(N1).MELEME
  56. POINTEUR ICHEVA(N1).MCHEVA
  57. ENDSEGMENT
  58. SEGMENT MCHEVA
  59. REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM)
  60. ENDSEGMENT
  61. SEGMENT LCHEVA
  62. POINTEUR LISCHE(NBCHE).MCHEVA
  63. ENDSEGMENT
  64. CENDINCLUDE SMCHAEL
  65. INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
  66. POINTEUR JCOOR.MCHEVA
  67. POINTEUR KCOOR.MCHEVA
  68. POINTEUR FFFAC.MCHEVA
  69. POINTEUR DFFFAC.MCHEVA
  70. POINTEUR JMAJA2.MCHEVA
  71. POINTEUR JMIJA2.MCHEVA
  72. POINTEUR JDTJA2.MCHEVA
  73. CBEGININCLUDE SELREF
  74. SEGMENT ELREF
  75. CHARACTER*(LNNOM) NOMLRF
  76. CHARACTER*(LNFORM) FORME
  77. CHARACTER*(LNTYPL) TYPEL
  78. CHARACTER*(LNESP) ESPACE
  79. INTEGER DEGRE
  80. REAL*8 XCONOD(NDIMEL,NBNOD)
  81. INTEGER NPQUAF(NBDDL)
  82. INTEGER NUMCMP(NBDDL)
  83. INTEGER QUENOD(NBDDL)
  84. INTEGER ORDDER(NDIMEL,NBDDL)
  85. POINTEUR MBPOLY.POLYNS
  86. ENDSEGMENT
  87. SEGMENT ELREFS
  88. POINTEUR LISEL(0).ELREF
  89. ENDSEGMENT
  90. CENDINCLUDE SELREF
  91. POINTEUR LRFVOL.ELREF
  92. POINTEUR LRFFAC.ELREF
  93. CBEGININCLUDE SFALRF
  94. SEGMENT FALRF
  95. CHARACTER*(LNNFA) NOMFA
  96. INTEGER NUQUAF(NBLRF)
  97. POINTEUR ELEMF(NBLRF).ELREF
  98. ENDSEGMENT
  99. SEGMENT FALRFS
  100. POINTEUR LISFA(0).FALRF
  101. ENDSEGMENT
  102. CENDINCLUDE SFALRF
  103. POINTEUR MYFALS.FALRFS
  104. CBEGININCLUDE SPOGAU
  105. SEGMENT POGAU
  106. CHARACTER*(LNNPG) NOMPG
  107. CHARACTER*(LNTPG) TYPMPG
  108. CHARACTER*(LNFPG) FORLPG
  109. INTEGER NORDPG
  110. REAL*8 XCOPG(NDLPG,NBPG)
  111. REAL*8 XPOPG(NBPG)
  112. ENDSEGMENT
  113. SEGMENT POGAUS
  114. POINTEUR LISPG(0).POGAU
  115. ENDSEGMENT
  116. CENDINCLUDE SPOGAU
  117. POINTEUR PGFAC.POGAU
  118. CBEGININCLUDE SFAPG
  119. SEGMENT FAPG
  120. CHARACTER*(LNNFAP) NOMFAP
  121. INTEGER NBQUAF(NBMPG)
  122. POINTEUR MPOGAU(NBMPG).POGAU
  123. ENDSEGMENT
  124. SEGMENT FAPGS
  125. POINTEUR LISFPG(0).FAPG
  126. ENDSEGMENT
  127. CENDINCLUDE SFAPG
  128. POINTEUR MYFPGS.FAPGS
  129. CBEGININCLUDE SIQUAF
  130. SEGMENT IQUAF
  131. INTEGER NUMQUF
  132. REAL*8 XCONQR(NDIMQR,NBNOQR)
  133. INTEGER NUCENT
  134. POINTEUR LFACE.MELEME
  135. ENDSEGMENT
  136. SEGMENT IQUAFS
  137. POINTEUR LISQRF(NBQRF).IQUAF
  138. ENDSEGMENT
  139. CENDINCLUDE SIQUAF
  140. POINTEUR IQUVOL.IQUAF
  141. *
  142. LOGICAL LERJ2
  143. CHARACTER*4 MYDISC,METING
  144. INTEGER NBELEV,NBELEF,NBELFV
  145. INTEGER IMPR,IRET
  146. *
  147. * Executable statements
  148. *
  149. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans geolf2'
  150. *
  151. * 1ere etape : on crée les ddl de la transfo geometrique
  152. *
  153. SEGACT IQUVOL
  154. NDIMQR=IQUVOL.XCONQR(/1)
  155. NBNOQR=IQUVOL.XCONQR(/2)
  156. SEGDES IQUVOL
  157. SEGACT LRFVOL
  158. NDDLVO=LRFVOL.NPQUAF(/1)
  159. JG=NBNOQR
  160. SEGINI KPQVOL
  161. DO IDDLVO=1,NDDLVO
  162. KPQVOL.LECT(LRFVOL.NPQUAF(IDDLVO))=IDDLVO
  163. ENDDO
  164. SEGDES LRFVOL
  165. SEGACT SFAVOL
  166. ITYFAC=SFAVOL.ITYPEL
  167. CALL KEEF(ITYFAC,MYDISC,
  168. $ MYFALS,
  169. $ LRFFAC,
  170. $ IMPR,IRET)
  171. IF (IRET.NE.0) GOTO 9999
  172. SEGACT LRFFAC
  173. NDDLFA=LRFFAC.NPQUAF(/1)
  174. SEGACT SSFACT
  175. NBELFV=SSFACT.LFACTI(/1)
  176. NBELEV=SSFACT.LFACTI(/2)
  177. NBLIG=1
  178. NBCOL=NDDLFA
  179. N2LIG=1
  180. N2COL=NDIMQR
  181. NBPOI=1
  182. NBELM=NBELEF
  183. SEGINI KCOOR
  184. SEGACT JCOOR
  185. IBELEF=0
  186. DO IBELEV=1,NBELEV
  187. DO IBELFV=1,NBELFV
  188. IF (SSFACT.LFACTI(IBELFV,IBELEV)) THEN
  189. IBELEF=IBELEF+1
  190. DO IDDLFA=1,NDDLFA
  191. IBNOQR=SFAVOL.NUM(LRFFAC.NPQUAF(IDDLFA),IBELFV)
  192. IBNOVO=KPQVOL.LECT(IBNOQR)
  193. DO IDIMQR=1,NDIMQR
  194. KCOOR.VELCHE(1,IDDLFA,1,IDIMQR,1,IBELEF)=
  195. $ JCOOR.VELCHE(1,IBNOVO,1,IDIMQR,1,IBELEV)
  196. ENDDO
  197. ENDDO
  198. ENDIF
  199. ENDDO
  200. ENDDO
  201. SEGDES JCOOR
  202. SEGDES SSFACT
  203. SEGDES LRFFAC
  204. SEGDES SFAVOL
  205. SEGSUP KPQVOL
  206. *
  207. * 2ème étape : - on crée les fonctions de forme et leurs dérivées
  208. * pour la transformation géométrie face -> volume
  209. * - on récupère coordonnées et poids des points de
  210. * Gauss pour la méthode METING sur la face de
  211. * référence
  212. * - pour chaque face de l'élément de référence volumique
  213. * on construit les coordonnées des points de Gauss
  214. * attenant à l'aide de la transformation géométrique
  215. *
  216. CALL KEPG(ITYFAC,METING,
  217. $ MYFPGS,
  218. $ PGFAC,
  219. $ IMPR,IRET)
  220. IF (IRET.NE.0) GOTO 9999
  221. *
  222. * In KFNREF : SEGINI FFFAC
  223. * In KFNREF : SEGINI DFFFAC
  224. *
  225. CALL KFNREF(LRFFAC,PGFAC,
  226. $ FFFAC,DFFFAC,
  227. $ IMPR,IRET)
  228. IF (IRET.NE.0) GOTO 9999
  229. SEGSUP FFFAC
  230. *
  231. * 3ème étape : On crée le déterminant de la matrice jacobienne
  232. * aux points de Gauss et on multiplie
  233. * les poids des points de Gauss par ce déterminant
  234. *
  235. * In GEOLIN : SEGINI JMAJA2
  236. * In GEOLIN : SEGINI JMIJA2
  237. * In GEOLIN : SEGINI JDTJA2
  238. * SEGPRT,DFFFAC
  239. * SEGPRT,KCOOR
  240. CALL GEOLIN(DFFFAC,KCOOR,NBELEF,
  241. $ JMAJA2,JMIJA2,JDTJA2,LERJ2,
  242. $ IMPR,IRET)
  243. IF (IRET.NE.0) GOTO 9999
  244. * SEGPRT,JDTJA2
  245. * In GEOLIN : SEGDES JMAJA2
  246. * In GEOLIN : SEGDES JMIJA2
  247. * In GEOLIN : SEGDES JDTJA2
  248. SEGSUP DFFFAC
  249. SEGSUP KCOOR
  250. * SEGPRT,IQUVOL
  251. * SEGPRT,SFAVOL
  252. * SEGPRT,LRFVOL
  253. * SEGPRT,LRFFAC
  254. * SEGPRT,SSFACT
  255. * SEGPRT, JCOOR
  256. * SEGPRT, KCOOR
  257. * SEGPRT,PGFAC
  258. * SEGPRT,DFFFAC
  259. * SEGPRT,JMAJA2
  260. * SEGPRT,JDTJA2
  261. * STOP 16
  262.  
  263. *
  264. * Normal termination
  265. *
  266. IRET=0
  267. RETURN
  268. *
  269. * Format handling
  270. *
  271. *
  272. * Error handling
  273. *
  274. 9999 CONTINUE
  275. IRET=1
  276. WRITE(IOIMP,*) 'An error was detected in subroutine geolf2'
  277. RETURN
  278. *
  279. * End of subroutine GEOLF2
  280. *
  281. END
  282.  
  283.  
  284.  

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