Télécharger extfac.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTFAC SOURCE GOUNAND 06/08/04 21:15:36 5520
  2. SUBROUTINE EXTFAC(CGEOM3,CSGEO3,MYQRFS,
  3. $ CGEOME,FACTIV,
  4. $ IMPR,IRET)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM : EXTFAC
  9. C DESCRIPTION : On extrait de CGEOM3 les éléments qui ont au moins une
  10. C face appartenant à CSGEO3 et un objet MELEME détourné
  11. C contenant les faces actives.
  12. C
  13. C
  14. C
  15. C LANGAGE : ESOPE
  16. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  17. C mél : gounand@semt2.smts.cea.fr
  18. C***********************************************************************
  19. C APPELES :
  20. C APPELES (E/S) :
  21. C APPELES (BLAS) :
  22. C APPELES (CALCUL) :
  23. C APPELE PAR :
  24. C***********************************************************************
  25. C SYNTAXE GIBIANE :
  26. C ENTREES :
  27. C ENTREES/SORTIES :
  28. C SORTIES :
  29. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  30. C***********************************************************************
  31. C VERSION : v1, 17/12/2002, version initiale
  32. C HISTORIQUE : v1, 17/12/2002, création
  33. C HISTORIQUE :
  34. C HISTORIQUE :
  35. C***********************************************************************
  36. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  37. C en cas de modification de ce sous-programme afin de faciliter
  38. C la maintenance !
  39. C***********************************************************************
  40. -INC CCOPTIO
  41. -INC SMCOORD
  42. -INC SMELEME
  43. POINTEUR CGEOM3.MELEME,SCGEO3.MELEME
  44. POINTEUR CSGEO3.MELEME,SCSGE3.MELEME
  45. POINTEUR CGEOME.MELEME,SCGEOM.MELEME
  46. POINTEUR FACVOL.MELEME,SFAVOL.MELEME
  47. INTEGER NBNN,NBELEM,NBSOUS,NBREF
  48. * Segment à moi
  49. SEGMENT VOLTIV
  50. POINTEUR IVOLTI(NBSOUV).SVOLTI
  51. ENDSEGMENT
  52. SEGMENT SVOLTI
  53. LOGICAL LVOLTI(NBELEV)
  54. ENDSEGMENT
  55. CBEGININCLUDE SFACTIV
  56. SEGMENT FACTIV
  57. POINTEUR IFACTI(NBSOUV).SFACTI
  58. ENDSEGMENT
  59. SEGMENT SFACTI
  60. POINTEUR ISFACT(NBSOFV).SSFACT
  61. ENDSEGMENT
  62. SEGMENT SSFACT
  63. LOGICAL LFACTI(NBELFV,NBELEV)
  64. ENDSEGMENT
  65. CENDINCLUDE SFACTIV
  66. INTEGER NBSOUV,NBSOFV,NBELEV
  67. CBEGININCLUDE SMLLOGI
  68. SEGMENT MLLOGI
  69. LOGICAL LOGI(JG)
  70. ENDSEGMENT
  71. CENDINCLUDE SMLLOGI
  72. POINTEUR KRSURF.MLLOGI
  73. INTEGER JG
  74. CBEGININCLUDE SIQUAF
  75. SEGMENT IQUAF
  76. INTEGER NUMQUF
  77. REAL*8 XCONQR(NDIMQR,NBNOQR)
  78. INTEGER NUCENT
  79. POINTEUR LFACE.MELEME
  80. ENDSEGMENT
  81. SEGMENT IQUAFS
  82. POINTEUR LISQRF(NBQRF).IQUAF
  83. ENDSEGMENT
  84. CENDINCLUDE SIQUAF
  85. POINTEUR MYQRFS.IQUAFS
  86. POINTEUR IQUVOL.IQUAF
  87. POINTEUR IQUFAC.IQUAF
  88. *
  89. INTEGER IMPR,IRET
  90. *
  91. INTEGER NBSOUF,NBELEF
  92. INTEGER IBSOUF,IBELEF,IBSOUV,IBELEV
  93. INTEGER NBELFV,NBNNV,NBELVA
  94. INTEGER IBSOFV,IBELFV,IBNNV,IBELVA
  95. INTEGER NUCFAC,NGLFAC,NPLFAC,NPCFAC
  96. INTEGER ITYVOL,ITYFAC
  97. LOGICAL LFOUND
  98.  
  99.  
  100. *
  101. * Executable statements
  102. *
  103. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans extfac.eso'
  104. *
  105. * On construit KRSURF : KRSURF(i) = VRAI si i est un numéro global
  106. * du centre d'un élément de CSGEO3 (point face)
  107. *
  108. JG=XCOOR(/1)/(IDIM+1)
  109. SEGINI,KRSURF
  110. SEGACT CSGEO3
  111. NBSOUF=CSGEO3.LISOUS(/1)
  112. DO IBSOUF=1,NBSOUF
  113. SCSGE3=CSGEO3.LISOUS(IBSOUF)
  114. SEGACT SCSGE3
  115. ITYFAC=SCSGE3.ITYPEL
  116. CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
  117. IF (IRET.NE.0) GOTO 9999
  118. SEGACT IQUFAC
  119. NUCFAC=IQUFAC.NUCENT
  120. SEGDES IQUFAC
  121. NBELEF=SCSGE3.NUM(/2)
  122. DO IBELEF=1,NBELEF
  123. NGLFAC=SCSGE3.NUM(NUCFAC,IBELEF)
  124. KRSURF.LOGI(NGLFAC)=.TRUE.
  125. ENDDO
  126. SEGDES SCSGE3
  127. ENDDO
  128. SEGDES CSGEO3
  129. * segprt,krsurf
  130. *
  131. * On parcourt l'objet maillage CGEOM3 en notant les éléments ayant
  132. * au moins une face active LVOLTI(IBELEV)=.TRUE.
  133. *
  134. SEGACT CGEOM3
  135. NBSOUV=CGEOM3.LISOUS(/1)
  136. SEGINI,VOLTIV
  137. DO IBSOUV=1,NBSOUV
  138. SCGEO3=CGEOM3.LISOUS(IBSOUV)
  139. SEGACT SCGEO3
  140. NBELEV=SCGEO3.NUM(/2)
  141. SEGINI,SVOLTI
  142. ITYVOL=SCGEO3.ITYPEL
  143. CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET)
  144. IF (IRET.NE.0) GOTO 9999
  145. SEGACT IQUVOL
  146. FACVOL=IQUVOL.LFACE
  147. SEGDES IQUVOL
  148. SEGACT FACVOL
  149. NBSOFV=FACVOL.LISOUS(/1)
  150. DO IBSOFV=1,NBSOFV
  151. SFAVOL=FACVOL.LISOUS(IBSOFV)
  152. * segprt,sfavol
  153. SEGACT SFAVOL
  154. ITYFAC=SFAVOL.ITYPEL
  155. CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
  156. IF (IRET.NE.0) GOTO 9999
  157. SEGACT IQUFAC
  158. NUCFAC=IQUFAC.NUCENT
  159. SEGDES IQUFAC
  160. NBELFV=SFAVOL.NUM(/2)
  161. DO IBELEV=1,NBELEV
  162. LFOUND=.FALSE.
  163. DO IBELFV=1,NBELFV
  164. NPLFAC=SFAVOL.NUM(NUCFAC,IBELFV)
  165. NPCFAC=SCGEO3.NUM(NPLFAC,IBELEV)
  166. * Write(ioimp,*) 'nplfac=',nplfac,' npcfac=',npcfac
  167. LFOUND=LFOUND.OR.KRSURF.LOGI(NPCFAC)
  168. ENDDO
  169. SVOLTI.LVOLTI(IBELEV)=LFOUND.OR.SVOLTI.LVOLTI(IBELEV)
  170. ENDDO
  171. SEGDES,SFAVOL
  172. ENDDO
  173. SEGDES,SVOLTI
  174. * SEGPRT,SVOLTI
  175. VOLTIV.IVOLTI(IBSOUV)=SVOLTI
  176. SEGDES FACVOL
  177. SEGDES SCGEO3
  178. ENDDO
  179. SEGDES VOLTIV
  180. SEGDES CGEOM3
  181. *
  182. * On construit l'objet maillage CGEOME contenant uniquement
  183. * les éléments ayant au moins une face active
  184. *
  185. SEGACT CGEOM3
  186. NBSOUV=CGEOM3.LISOUS(/1)
  187. NBNN=0
  188. NBELEM=0
  189. NBSOUS=NBSOUV
  190. NBREF=0
  191. SEGINI CGEOME
  192. SEGACT VOLTIV
  193. IBSOV2=0
  194. DO IBSOUV=1,NBSOUV
  195. SCGEO3=CGEOM3.LISOUS(IBSOUV)
  196. SEGACT SCGEO3
  197. NBNNV=SCGEO3.NUM(/1)
  198. NBELEV=SCGEO3.NUM(/2)
  199. SVOLTI=VOLTIV.IVOLTI(IBSOUV)
  200. SEGACT SVOLTI
  201. * Trouver le nombre d'éléments actifs dans ce maillage élémentaire
  202. NBELVA=0
  203. DO IBELEV=1,NBELEV
  204. IF (SVOLTI.LVOLTI(IBELEV)) THEN
  205. NBELVA=NBELVA+1
  206. ENDIF
  207. ENDDO
  208. IF (NBELVA.GT.0) THEN
  209. NBNN=NBNNV
  210. NBELEM=NBELVA
  211. NBSOUS=0
  212. NBREF=0
  213. SEGINI,SCGEOM
  214. SCGEOM.ITYPEL=SCGEO3.ITYPEL
  215. IBELVA=0
  216. DO IBELEV=1,NBELEV
  217. IF (SVOLTI.LVOLTI(IBELEV)) THEN
  218. IBELVA=IBELVA+1
  219. DO IBNNV=1,NBNNV
  220. SCGEOM.NUM(IBNNV,IBELVA)=SCGEO3.NUM(IBNNV,IBELEV)
  221. ENDDO
  222. ENDIF
  223. ENDDO
  224. SEGDES,SCGEOM
  225. IBSOV2=IBSOV2+1
  226. CGEOME.LISOUS(IBSOV2)=SCGEOM
  227. ENDIF
  228. *DEBUG SEGPRT,SVOLTI
  229. SEGSUP SVOLTI
  230. SEGDES SCGEO3
  231. ENDDO
  232. *DEBUG SEGPRT,VOLTIV
  233. SEGSUP VOLTIV
  234. NBNN=0
  235. NBELEM=0
  236. NBSOUS=IBSOV2
  237. NBREF=0
  238. SEGADJ,CGEOME
  239. SEGDES CGEOME
  240. SEGDES CGEOM3
  241. *DEBUG CALL ECROBJ('MAILLAGE',CGEOME)
  242. *DEBUG CALL PRLIST
  243. *DEBUG CALL ECROBJ('MAILLAGE',CGEOM3)
  244. *DEBUG CALL PRLIST
  245. *
  246. * On parcourt l'objet maillage CGEOME en notant les faces actives des
  247. * éléments LFACTI(IBFAVO,IBELEV)=.TRUE.
  248. *
  249. SEGACT CGEOME
  250. NBSOUV=CGEOME.LISOUS(/1)
  251. SEGINI,FACTIV
  252. DO IBSOUV=1,NBSOUV
  253. SCGEOM=CGEOME.LISOUS(IBSOUV)
  254. SEGACT SCGEOM
  255. ITYVOL=SCGEOM.ITYPEL
  256. CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET)
  257. IF (IRET.NE.0) GOTO 9999
  258. SEGACT IQUVOL
  259. FACVOL=IQUVOL.LFACE
  260. SEGDES IQUVOL
  261. SEGACT FACVOL
  262. NBSOFV=FACVOL.LISOUS(/1)
  263. SEGINI,SFACTI
  264. DO IBSOFV=1,NBSOFV
  265. SFAVOL=FACVOL.LISOUS(IBSOFV)
  266. SEGACT SFAVOL
  267. ITYFAC=SFAVOL.ITYPEL
  268. CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
  269. IF (IRET.NE.0) GOTO 9999
  270. SEGACT IQUFAC
  271. NUCFAC=IQUFAC.NUCENT
  272. SEGDES IQUFAC
  273. NBELFV=SFAVOL.NUM(/2)
  274. NBELEV=SCGEOM.NUM(/2)
  275. SEGINI SSFACT
  276. DO IBELEV=1,NBELEV
  277. DO IBELFV=1,NBELFV
  278. NPLFAC=SFAVOL.NUM(NUCFAC,IBELFV)
  279. NPCFAC=SCGEOM.NUM(NPLFAC,IBELEV)
  280. SSFACT.LFACTI(IBELFV,IBELEV)=KRSURF.LOGI(NPCFAC)
  281. ENDDO
  282. ENDDO
  283. SEGDES SSFACT
  284. * SEGPRT,SSFACT
  285. SFACTI.ISFACT(IBSOFV)=SSFACT
  286. SEGDES SFAVOL
  287. ENDDO
  288. SEGDES SFACTI
  289. * SEGPRT,SFACTI
  290. FACTIV.IFACTI(IBSOUV)=SFACTI
  291. SEGDES FACVOL
  292. SEGDES SCGEOM
  293. ENDDO
  294. SEGDES FACTIV
  295. * SEGPRT,FACTIV
  296. SEGDES CGEOME
  297. SEGSUP,KRSURF
  298. *
  299. * Normal termination
  300. *
  301. IRET=0
  302. RETURN
  303. *
  304. * Format handling
  305. *
  306. *
  307. * Error handling
  308. *
  309. 9999 CONTINUE
  310. IRET=1
  311. WRITE(IOIMP,*) 'An error was detected in subroutine extfac'
  312. RETURN
  313. *
  314. * End of subroutine EXTFAC
  315. *
  316. END
  317.  
  318.  
  319.  

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