Télécharger la plaquette Cast3M


fr en

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