Télécharger la plaquette Cast3M


fr en

Télécharger uniqma.eso

Retour à la liste

Numérotation des lignes : 

uniqma

  1. C UNIQMA    SOURCE    SP204843  23/07/13    21:15:05     11709          
  2. C
  3.       subroutine uniqma(ipt1,nbdif,iordre)
  4. C
  5. C  construit un maillage constitue des elements unique d'un autre maillage
  6. c  si iordre est nul, l'ordre des noeuds dans l'element n'est pas discriminant 
  7. c  si iordre vaut un, l'ordre des noeuds dans l'element estdiscriminant 
  8. C
  9. C  uniqma gere les chapeaux du meleme, uniqm1 gere les lisous
  10. C
  11.       implicit real*8 (a-h,o-z)
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. -INC SMELEME
  16. -INC SMCOORD
  17.       segment netn(nbpts)
  18.       segment ietn(letn)
  19. C
  20. C*    call lirobj('MAILLAGE',ipt1,1,iretou)
  21. C*    if (ierr.ne.0) return
  22.       segact ipt1
  23.       nbdif=0
  24.       nbdi1=0
  25.  
  26.       if (ipt1.lisous(/1).eq.0) then
  27. C       Cas MELEME SIMPLE
  28. C       if (ipt1.num(/2).ne.0) then
  29.          call uniqm1(ipt1,ipt2,nbdif,iordre)
  30. C       else
  31. C        segini,ipt2=ipt1
  32. C       endif
  33.         goto 1000
  34.       endif
  35.  
  36. C     Cas MELEME COMPLEXE
  37.       segini,ipt2=ipt1
  38.       do 100 is=1,ipt2.lisous(/1)
  39.        ipt3=ipt2.lisous(is)
  40.        if (ipt3.eq.0) goto 100
  41.        segact ipt3
  42. C verif pas d'autre paquet semblables
  43.        do 110 is2=is+1,ipt2.lisous(/1)
  44.         ipt4=ipt2.lisous(is2)
  45.         if (ipt4.eq.0) goto 110
  46.         segact ipt4
  47.         if (ipt4.itypel.ne.ipt3.itypel) goto 110
  48.         if (ipt4.num(/1).ne.ipt3.num(/1)) goto 110
  49.  
  50. C concatenation de ipt3 et ipt4
  51.         nbnn  =ipt3.num(/1)
  52.         nbelem=ipt3.num(/2)+ipt4.num(/2)
  53.         nbsous=0
  54.         nbref =0
  55.         segini ipt5
  56.         ipt5.itypel=ipt3.itypel
  57.         do  j=1,ipt3.num(/2)
  58.           do  i=1,ipt3.num(/1)
  59.             ipt5.num(i,j)=ipt3.num(i,j)
  60.           enddo
  61.           ipt5.icolor(j)=ipt3.icolor(j)
  62.         enddo
  63.  
  64.         do  j=1,ipt4.num(/2)
  65.           j1=j+ipt3.num(/2)
  66.           do  i=1,ipt4.num(/1)
  67.             ipt5.num(i,j1)=ipt4.num(i,j)
  68.           enddo
  69.           ipt5.icolor(j1)=ipt4.icolor(j)
  70.         enddo
  71.  
  72.         segdes ipt3,ipt4
  73.         ipt3=ipt5
  74.         ipt2.lisous(is2)=0
  75.  110   continue
  76.        call uniqm1(ipt3,ipt4,nbdi1,iordre)
  77.        nbdif = nbdif + nbdi1
  78.        ipt2.lisous(is)=ipt4
  79.  100  continue
  80.  
  81. C     Si pas de difference => Identite
  82.       if (nbdif.eq.0) then
  83.         segsup, ipt2
  84.         return
  85.       endif
  86.  
  87. C  compression du segment
  88.       nbsous=0
  89.       do 200 is=1,ipt2.lisous(/1)
  90.        if (ipt2.lisous(is).ne.0) then
  91.         nbsous=nbsous+1
  92.         ipt2.lisous(nbsous)=ipt2.lisous(is)
  93.        endif
  94.  200  continue
  95.       nbref =0
  96.       nbnn  =0
  97.       nbelem=0
  98.       segadj ipt2
  99.       if (nbsous.eq.1) then
  100.         ipt2=ipt2.lisous(1)
  101.       endif
  102. C
  103.  1000 continue
  104.       ipt1=ipt2
  105.       return
  106.       end
  107.  
  108.  
  109.  
  110.  
  111.  
  112.  
  113.  
  114.  

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