Télécharger exto4c.eso

Retour à la liste

Numérotation des lignes :

exto4c
  1. C EXTO4C SOURCE GOUNAND 21/04/06 21:15:10 10940
  2. SUBROUTINE EXTO4C(JELEM,TRAVJ,
  3. $ TRAVX)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. IMPLICIT INTEGER (I-N)
  6. C***********************************************************************
  7. C NOM : EXTO4C
  8. C DESCRIPTION : Extraction de la topologie locale proprement dite
  9. C On utilise un segment de travail TRAVV dans le cas où JELEM de
  10. C dimension le nombre d'éléments de JTOPO lorsque JELEM a plus d'un
  11. C noeud. Ici, on retourne les éléments de JTOPO (même si ici, on ne
  12. C connaît que TOPINV) à extraire dans le tableau NEXTO du segment de
  13. C travail TRAVX
  14. C
  15. C On a repris la programmation de EXTO3
  16. C
  17. C LANGAGE : ESOPE
  18. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SEMT/LTA)
  19. C mél : gounand@semt2.smts.cea.fr
  20. C***********************************************************************
  21. C APPELES :
  22. C APPELES (E/S) :
  23. C APPELES (BLAS) :
  24. C APPELES (CALCUL) :
  25. C APPELE PAR :
  26. C***********************************************************************
  27. C SYNTAXE GIBIANE :
  28. C ENTREES : JELEM, TOPINV, TRAVV
  29. C ENTREES/SORTIES : TRAVX
  30. C SORTIES :
  31. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  32. C***********************************************************************
  33. C VERSION : v1, 11/10/2017, version initiale
  34. C HISTORIQUE : v1, 11/10/2017, création
  35. C HISTORIQUE :
  36. C HISTORIQUE :
  37. C***********************************************************************
  38. -INC PPARAM
  39. -INC CCOPTIO
  40. -INC SMLENTI
  41. POINTEUR JNBL.MLENTI
  42. POINTEUR NEXTO.MLENTI
  43. -INC SMELEME
  44. *
  45. * Le nombre d'éléments de JTOPO et le nombre de points de JCOORD
  46. * vont être variables. Pour ne pas avoir à ajuster ces segments en
  47. * permanence, on va dimensionner plus large, mais du coup, il faut
  48. * aussi maintenir à la main le nombre de noeuds et d'éléments
  49. * courants.
  50. *
  51. * Le nombre d'éléments courants est NVCOU et le nombre d'éléments
  52. * max est NVMAX. Idem pour le nombre de noeuds courants et max :
  53. * NPCOU et NPMAX.
  54. *
  55. * Numerotation locale des éléments JTOPO.NUM(NBNN,NBELEM)
  56. *del POINTEUR JTOPO.MELEME
  57. POINTEUR JELEM.MELEME
  58. *del POINTEUR JEXTO.MELEME
  59. -INC TMATOP2
  60. -INC TMATOP1
  61. *-INC STOPINV
  62. *-INC STRAVJ
  63. POINTEUR TRAVX.TRAVJ
  64. *
  65. *del INTEGER IMPR,IRET
  66. logical lchang
  67. *
  68. * Executable statements
  69. *
  70. if (impr.ge.5) WRITE(IOIMP,*) 'Entrée dans exto4c.eso'
  71. *
  72. IDIMP=IDIM+1
  73. TOPINV=TRAVJ.TOPI
  74. NEXTO=TRAVX.NBL
  75. * On gère le cas où certains noeuds de JELEM sont nuls ou ne sont
  76. * plus dans la topologie
  77. NPOJEL=0
  78. IP1=0
  79. DO IPO=1,JELEM.NUM(/1)
  80. IP=JELEM.NUM(IPO,1)
  81. IF (IP.NE.0) THEN
  82. IF (TDC(IP).NE.0) THEN
  83. NPOJEL=NPOJEL+1
  84. IF (IP1.EQ.0) IP1=IP
  85. ENDIF
  86. ENDIF
  87. ENDDO
  88. *
  89. * Dans le cas où NPOJEL=0 : maillage vide
  90. *
  91. IF (NPOJEL.EQ.0) THEN
  92. NVXCOU=0
  93. TRAVX.NVCOU=NVXCOU
  94. *
  95. * Dans le cas où NPOJEL=1, on peut extraire tout de suite
  96. *
  97. ELSEIF (NPOJEL.EQ.1) THEN
  98. IP=IP1
  99. NVXCOU=TDC(IP)
  100. CALL TOPADV(TRAVX,NVXCOU,1,lchang,'exto4c : TRAVX npojel=1')
  101. if (ierr.ne.0) return
  102. if (iveri.ge.2.and.lchang) then
  103. call vetopi(travx,'exto4c : Apres extension travx npojel=1')
  104. if (ierr.ne.0) return
  105. endif
  106. *
  107. *
  108. LAST=TIC(IP)
  109. LDG=TDC(IP)
  110. DO IDG=1,LDG
  111. IL=((LAST-1)/IDIMP)+1
  112. * Remplissage à l'envers (inverse l'ordre des éléments par rapport a
  113. * JTOPO)
  114. * IEL=IDG
  115. * Remplissage à l'endroit (garde l'ordre des éléments par rapport a
  116. * JTOPO)
  117. IEL=LDG+1-IDG
  118. NEXTO.LECT(IEL)=IL
  119. LAST=TLC(LAST)
  120. ENDDO
  121. ELSE
  122. *
  123. * Recherche du noeud de JELEM appartenant au plus petit nombre
  124. * d'éléments
  125. *
  126. NLMIN=0
  127. IMIN=0
  128. DO IPOJEL=1,NPOJEL
  129. IP=JELEM.NUM(IPOJEL,1)
  130. IF (IP.NE.0) THEN
  131. IDIP=TDC(IP)
  132. c$$$ IF (IDIP.LE.0) THEN
  133. c$$$ write(ioimp,*) 'pas normal '
  134. c$$$ write(ioimp,185) 'nvini,nvcou,nvmax=',nvini,nvcou
  135. c$$$ $ ,nvmax
  136. c$$$ write(ioimp,185) 'npini,npcou,npmax=',npini,npcou
  137. c$$$ $ ,npmax
  138. c$$$ write(ioimp,*) 'jelem(nno,nbnn=)',jelem.num(/1)
  139. c$$$ $ ,jelem.num(/2)
  140. c$$$ call ecmai1(jelem,0)
  141. c$$$ write(ioimp,*) 'jtopo'
  142. c$$$ jtopo=travj.topo
  143. c$$$ call ecmai1(jtopo,0)
  144. c$$$ segact jtopo*mod
  145. c$$$ call ectopi(topinv,1)
  146. c$$$ call ectopi(topinv,2)
  147. c$$$ goto 9999
  148. c$$$ ENDIF
  149. IF(IDIP.NE.0) THEN
  150. IF (NLMIN.EQ.0) THEN
  151. NLMIN=IDIP
  152. IMIN=IPOJEL
  153. ELSE
  154. IF (IDIP.LT.NLMIN) THEN
  155. NLMIN=IDIP
  156. IMIN=IPOJEL
  157. ENDIF
  158. ENDIF
  159. ENDIF
  160. ENDIF
  161. ENDDO
  162. IF (IMIN.EQ.0) THEN
  163. write(ioimp,*) 'Maillage JELEM vide non prevu ici'
  164. goto 9999
  165. ENDIF
  166. * if (impr.gt.2) write(ioimp,*) 'Le noeud ',IMIN,'/',NPOJEL
  167. * $ ,' de IELEM de numero ',JELEM.NUM(IMIN,1)
  168. * $ ,' a le plus petit nb de voisins :',NLMIN
  169. if (impr.gt.2) write(ioimp,189) IMIN,NPOJEL,JELEM.NUM(IMIN,1)
  170. $ ,NLMIN
  171. *
  172. * Quels sont les éléments appartenant à ce noeud minimal (on les
  173. * note par 1 dans NBL de TRAVJ)
  174. *
  175. JNBL=TRAVJ.NBL
  176. * Fait dans exto2 SEGINI TRAVV
  177. IP=JELEM.NUM(IMIN,1)
  178. *
  179. LAST=TIC(IP)
  180. LDG=TDC(IP)
  181. DO IDG=1,LDG
  182. IL=((LAST-1)/IDIMP)+1
  183. JNBL.LECT(IL)=1
  184. LAST=TLC(LAST)
  185. ENDDO
  186. if (impr.gt.2) then
  187. * write(ioimp,*) 'Apres point IELEM(',IMIN,',1)=',IP,' ; NBL='
  188. * write(ioimp,187) (JNBL.LECT(I),I=1,jnbl.lect(/1))
  189. write(ioimp,188) IMIN,IP
  190. write(ioimp,187) (JNBL.LECT(I),I=1,jnbl.lect(/1))
  191. endif
  192. *
  193. * Les éléments des autres noeuds de JELEM
  194. * + on compte le nombre d'éléments à construire
  195. *
  196. NLEXT=0
  197. DO IPOJEL=1,NPOJEL
  198. IF (IPOJEL.NE.IMIN) THEN
  199. IP=JELEM.NUM(IPOJEL,1)
  200. IF (IP.NE.0) THEN
  201. LAST=TIC(IP)
  202. LDG=TDC(IP)
  203. DO IDG=1,LDG
  204. IL=((LAST-1)/IDIMP)+1
  205. IF (JNBL.LECT(IL).GT.0) THEN
  206. JNBL.LECT(IL)=JNBL.LECT(IL)+1
  207. IF (JNBL.LECT(IL).EQ.NPOJEL) NLEXT=NLEXT+1
  208. ENDIF
  209. LAST=TLC(LAST)
  210. ENDDO
  211. if (impr.gt.2) then
  212. * write(ioimp,*) 'Apres point IELEM(',IPOJEL,',1)=',IP
  213. * $ ,' ; NBL='
  214. write(ioimp,188) IPOJEL,IP
  215. write(ioimp,187) (JNBL.LECT(I),I=1,jnbl.lect(/1))
  216. endif
  217. ENDIF
  218. ENDIF
  219. ENDDO
  220. *
  221. * On parcourt une dernière fois le IMIN pour construire le maillage
  222. * extrait et mettre à zéro TRAVV
  223. *
  224. IP=JELEM.NUM(IMIN,1)
  225. *
  226. NVXCOU=NLEXT
  227. CALL TOPADV(TRAVX,NVXCOU,1,lchang,'exto4c : TRAVX npojel>1')
  228. if (ierr.ne.0) return
  229. if (iveri.ge.2.and.lchang) then
  230. call vetopi(travx,'exto4c : Apres extension travx npojel>1')
  231. if (ierr.ne.0) return
  232. endif
  233. *
  234. NEXTO=TRAVX.NBL
  235. *
  236. LAST=TIC(IP)
  237. LDG=TDC(IP)
  238. IELL=1
  239. DO IDG=1,LDG
  240. IL=((LAST-1)/IDIMP)+1
  241. * write(ioimp,*) 'idg=',idg,' last=',last,' il=',il
  242. IF (JNBL.LECT(IL).EQ.NPOJEL) THEN
  243. * Remplissage à l'envers (inverse l'ordre des éléments par rapport a
  244. * JTOPO)
  245. * IEL=IELL
  246. * Remplissage à l'endroit (garde l'ordre des éléments par rapport a
  247. * JTOPO)
  248. IEL=NLEXT+1-IELL
  249. nexto.lect(iel)=il
  250. IELL=IELL+1
  251. ENDIF
  252. * Nettoyage TRAVV NBL
  253. JNBL.LECT(IL)=0
  254. LAST=TLC(LAST)
  255. ENDDO
  256.  
  257. * SEGSUP TRAVV
  258. ENDIF
  259. if (impr.gt.2) then
  260. write(ioimp,*)
  261. $ 'Elements de la topologie extraits :'
  262. write(ioimp,187) (nexto.lect(I),I=1,nvxcou)
  263. endif
  264. * JEXTO=JTOPO
  265. *
  266. * Normal termination
  267. *
  268. RETURN
  269. *
  270. * Format handling
  271. *
  272. 185 FORMAT (5X,A32,6I8)
  273. 186 FORMAT ('Segment ',A6,' ',A6,' ajusté de ',I6,' à ',I6)
  274. 187 FORMAT (5X,10I8)
  275. 188 FORMAT ('Apres point IELEM(',I2,',1)=',I6,' ; NBL=')
  276. 189 FORMAT ('Le noeud ',I2,'/',I2,' de IELEM de numero',I6
  277. $ ,' a le plus petit nb de voisins :',I3)
  278. *
  279. * Error handling
  280. *
  281. 9999 CONTINUE
  282. MOTERR(1:8)='EXTO4C '
  283. * 349 2
  284. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  285. CALL ERREUR(349)
  286. RETURN
  287. *
  288. * End of subroutine EXTO4C
  289. *
  290. END
  291.  
  292.  
  293.  

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