Télécharger la plaquette Cast3M


fr en

Télécharger isova5.eso

Retour à la liste

Numérotation des lignes : 

isova5

  1. C ISOVA5    SOURCE    PV        20/03/24    21:18:24     10554          
  2.       SUBROUTINE ISOVA5(NEWNOD,ELEMS,ITYPL)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : ISOVA5
  7. C DESCRIPTION : La pile NEWNOD contient généralement des noeuds
  8. *               géométriquement confondus : on les élimine.
  9. *               Puis, on incrémente le segment MCOORD avec le nouveaux
  10. *               noeuds non géométriquement confondus
  11. *               et on met à jour les piles d'éléments.
  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 VERSION    : v1, 15/09/2014, version initiale
  20. C HISTORIQUE : v1, 15/09/2014, création
  21. C HISTORIQUE :
  22. C***********************************************************************
  23.  
  24. -INC PPARAM
  25. -INC CCOPTIO
  26. -INC CCGEOME
  27. -INC SMLENTI
  28. -INC CCREEL
  29. -INC SMCOORD
  30. *
  31. * Segments ajustables 1D contenant les noeuds des éléments créés ainsi
  32. * que leur couleur
  33. * ELEM(1) contient des POI1
  34. * ELEM(2) contient des SEG2
  35. * ELEM(3) contient des TRI3
  36. * ELEM(4) contient des TET4
  37. * ELEM(5) contient des PYR5
  38. * ELEM(6) contient des PRI6
  39. * ELEM(7) contient des QUA4
  40. *
  41.       PARAMETER (NTYEL=7)
  42.       SEGMENT ELEMS
  43.       POINTEUR ELEM(NTYEL).MLENTI
  44.       ENDSEGMENT
  45. * Défini dans isova1
  46.       INTEGER ITYPL(NTYEL)
  47. *
  48. * Pile des nouveaux noeuds
  49.       SEGMENT NEWNOD
  50.       INTEGER NNOD
  51.       INTEGER NOEINF(MAXNOD)
  52.       INTEGER NOESUP(MAXNOD)
  53.       REAL*8  COEINF(MAXNOD)
  54.       ENDSEGMENT
  55. *
  56.       segment newnum(nnod)
  57. *
  58.       SEGMENT ICPR(nbpts)
  59.       segment inode(ino)
  60.       segment jelnum(imaxel,ino)
  61.       segment kelnum(imaxel,ino)
  62.       segment xelnum(imaxel,ino)
  63. *
  64.       LOGICAL LFOUND
  65. *
  66. * Executable statements
  67. *
  68. **********************************************************************
  69. *             Traitement des noeuds redondants
  70. **********************************************************************
  71. *
  72. * Trouver les noeuds redondants dans NEWNOD
  73. *
  74. * Création d'une numérotation locale
  75.       segini icpr
  76.       ino=0
  77.       do jnod=1,nnod
  78.          ia=noesup(jnod)
  79.          if(icpr(ia).eq.0) then
  80.             ino=ino+1
  81.             icpr(ia)=ino
  82.          endif
  83.       enddo
  84. * on compte combien de segment touche un noeud
  85.       segini inode
  86.       do jnod=1,nnod
  87.          ia=noesup(jnod)
  88.          ib=icpr(ia)
  89.          inode(ib)=inode(ib)+1
  90.       enddo
  91.       imaxel=0
  92.       do i=1,ino
  93.          imaxel=max(imaxel,inode(i))
  94. *         inode(i)=0
  95.       enddo
  96.       segsup inode
  97. * on crée les noeuds uniques et une nouvelle numérotation
  98. * dans newnum(jnod) : si newnum(jnod)=knod>0 le noeud jnod est à garder
  99. *                     et est numéroté knod dans la nouvelle num
  100. *                     si newnum(jnod)=-knod<0 le noeud jnod est à
  101. *                     supprimer, il est remplacé par knod dans la
  102. *                     nouvelle num
  103.       knod=0
  104.       ired=0
  105.       segini jelnum
  106.       segini kelnum
  107.       segini xelnum
  108.       segini newnum
  109.       do jnod=1,nnod
  110.          ia=noesup(jnod)
  111.          ib=icpr(ia)
  112.          lfound=.false.
  113.          do j=1,imaxel
  114.             if (jelnum(j,ib).eq.0) then
  115.                jelnum(j,ib)=noeinf(jnod)
  116.                xelnum(j,ib)=coeinf(jnod)
  117.                knod=knod+1
  118.                kelnum(j,ib)=knod
  119.                newnum(jnod)=knod
  120.                goto 103
  121.             elseif (jelnum(j,ib).eq.noeinf(jnod)) then
  122. *               if (xelnum(j,ib).eq.coeinf(jnod)) then
  123. * On met xzprec*10.D0 pour mimer le XTOL mis dans isoval.eso
  124.                if (abs(xelnum(j,ib)-coeinf(jnod)).le.(xzprec*10.d0))
  125.      $              then
  126.                   lfound=.true.
  127.                   newnum(jnod)=-kelnum(j,ib)
  128.                   goto 103
  129.                endif
  130.             endif
  131.          enddo
  132.  103     continue
  133.          if (lfound) then
  134.             ired=ired+1
  135.          else
  136.             if (ired.gt.0) then
  137.                noeinf(jnod-ired)=noeinf(jnod)
  138.                noesup(jnod-ired)=noesup(jnod)
  139.                coeinf(jnod-ired)=coeinf(jnod)
  140.             endif
  141.          endif
  142.       enddo
  143.       segsup jelnum
  144.       segsup kelnum
  145.       segsup xelnum
  146.       if (ired.gt.0) then
  147. *dbg         write(ioimp,*) 'il y a ired=',ired,' noeuds a eliminer'
  148. *dbg2         write(ioimp,*) 'Nouvelle numerotation :'
  149. *dbg2         write(ioimp,*) (newnum(i),i=1,newnum(/1))
  150.          nnod=nnod-ired
  151.          maxnod=nnod
  152.          segadj,newnod
  153. *
  154. * Passage dans la nouvelle numérotation dans les piles
  155. *
  156.          do ipil=1,7
  157.             mlenti=elem(ipil)
  158.             nnode=nbnne(itypl(ipil))
  159.             jg=lect(/1)
  160.             ng=jg/(nnode+1)
  161.             do ig=1,ng
  162.                do iloc=1,nnode
  163.                   idx=(nnode+1)*(ig-1)+iloc
  164. *                  write(ioimp,*) 'nnode=',nnode,' ig=',ig,' iloc=',iloc
  165. *                  write(ioimp,*) '  idx=',idx
  166.                   inod=lect(idx)
  167. * esope n'aime pas trop la forme suivante
  168. *                  if (inod.le.0) lect(idx)=-abs(newnum(-inod))
  169.                   if (inod.le.0) lect(idx)=-abs(newnum(0-inod))
  170.                enddo
  171.             enddo
  172.          enddo
  173.       endif
  174.       segsup newnum
  175. *
  176. * Création des nouveaux noeuds dans MCOORD et mise à jour
  177. * des numéros dans les piles d'éléments
  178. *
  179.       SEGACT MCOORD*MOD
  180.       IDIM1=IDIM+1
  181.       NBANC=nbpts
  182. *dbg      write(ioimp,*) 'Nombre de nouveaux/anciens noeuds=',NNOD,' ',NBANC
  183.       NBPTS=NBANC+NNOD
  184.       SEGADJ,MCOORD
  185.       DO JNOD=1,NNOD
  186.          num1=noeinf(jnod)
  187.          num2=noesup(jnod)
  188.          x1=coeinf(jnod)
  189.          x2=1.D0-x1
  190.          DO II=1,IDIM+1
  191.             XCOOR((NBANC+JNOD-1)*IDIM1+II)=
  192.      $           (XCOOR((NUM2-1)*IDIM1+II)*X2)+
  193.      $           (XCOOR((NUM1-1)*IDIM1+II)*X1)
  194.          ENDDO
  195.       ENDDO
  196.       SEGACT MCOORD
  197.       SEGSUP NEWNOD
  198. *
  199. * Mise à jour des noeuds dans les piles (cette étape peut être faite
  200. *juste avant la modif de MCOORD, on la garde pour clarté).
  201. *
  202.       do ipil=1,7
  203.          mlenti=elem(ipil)
  204.          nnode=nbnne(itypl(ipil))
  205.          jg=lect(/1)
  206.          ng=jg/(nnode+1)
  207.          do ig=1,ng
  208.             do iloc=1,nnode
  209.                idx=(nnode+1)*(ig-1)+iloc
  210. *                  write(ioimp,*) 'nnode=',nnode,' ig=',ig,' iloc=',iloc
  211. *                  write(ioimp,*) '  idx=',idx
  212.                inod=lect(idx)
  213.                if (inod.le.0) lect(idx)=nbanc-inod
  214.             enddo
  215.          enddo
  216.       enddo
  217. *
  218. * End of subroutine ISOVA5
  219. *
  220.       END
  221.  
  222.  
  223.  
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  

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