Télécharger la plaquette Cast3M


fr en

Télécharger elemel.eso

Retour à la liste

Numérotation des lignes : 

elemel

  1. C ELEMEL    SOURCE    GOUNAND   25/08/04    21:15:06     12340          
  2.       SUBROUTINE ELEMEL(IPT1,IPT2,MELEME,nbltot)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : ELEMEL
  7. C DESCRIPTION : Extrait les elements de IPT1 appuyes sur les
  8. C               elements de IPT2
  9. C               Un element de IPT1 est appuye sur un element de IPT2
  10. C               s'il contient tous les noeuds de ce dernier
  11. C
  12. C
  13. C LANGAGE     : ESOPE
  14. C AUTEUR      : Stephane GOUNAND (CEA/DES/ISAS/DM2S/SEMT/LTA)
  15. C               mel : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELES          :
  18. C APPELES (E/S)    :
  19. C APPELES (BLAS)   :
  20. C APPELES (CALCUL) :
  21. C APPELE PAR       :
  22. C***********************************************************************
  23. C SYNTAXE GIBIANE    :
  24. C ENTREES            :
  25. C ENTREES/SORTIES    :
  26. C SORTIES            :
  27. C***********************************************************************
  28. C VERSION    : v1, 01/08/2025, version initiale
  29. C HISTORIQUE : v1, 01/08/2025, creation
  30. C HISTORIQUE :
  31. C HISTORIQUE :
  32. C***********************************************************************
  33. -INC PPARAM
  34. -INC CCOPTIO
  35. -INC CCREEL
  36. -INC SMELEME
  37. -INC SMCOORD
  38.       segment icpr(nbpts)
  39.       segment ipos(nno2+1)
  40.       segment izone(nlel)
  41.       segment inum(nlel)
  42.       segment linum(imaxel)
  43.       segment lizone(imaxel)
  44.       segment imail(nbsou1)
  45.       logical lfound,ldbg
  46. *
  47. * Executable statements
  48. *
  49.       ldbg=.false.
  50. *
  51. *   Numerotation locale a ipt2
  52. *
  53.       call actobj(ipt2,'MAILLAGE',1)
  54.       segini icpr
  55.       nno2=0
  56.       ipt4=ipt2
  57.       DO IOB=1,MAX(1,IPT2.LISOUS(/1))
  58.          IF (IPT2.LISOUS(/1).NE.0) IPT4=IPT2.LISOUS(IOB)
  59.          if (ldbg) write(ioimp,*) 'IOB=',IOB
  60.          if (ldbg) segprt,IPT4
  61.          DO J=1,IPT4.NUM(/2)
  62.             DO I=1,IPT4.NUM(/1)
  63.                IKI=IPT4.NUM(I,J)
  64.                IF (ICPR(IKI).EQ.0) THEN
  65.                   nno2=nno2+1
  66.                   ICPR(IKI)=nno2
  67.                ENDIF
  68.             ENDDO
  69.          ENDDO
  70.       ENDDO
  71. *     Recopions les sous-maillages de ipt1 dans imail parce qu'on va les
  72. *     tagger, voir les reduire apres
  73.       call actobj(ipt1,'MAILLAGE',1)
  74.       nbsou1=MAX(1,IPT1.LISOUS(/1))
  75.       segini imail
  76.       ipt3=ipt1
  77.       DO isous=1,nbsou1
  78.          IF (IPT1.LISOUS(/1).NE.0) IPT3=IPT1.LISOUS(isous)
  79.          segini,ipt5=ipt3
  80.          imail(isous)=ipt5
  81.       ENDDO
  82.       if (ldbg) write(ioimp,*) 'nno2,nbsou1=',nno2,nbsou1
  83. *
  84. * Correspondance chaque noeud de ipt2, les elements de ipt1 le contenant
  85. *
  86.       segini ipos
  87.       DO isous=1,nbsou1
  88.          ipt3=imail(isous)
  89.          DO J=1,ipt3.NUM(/2)
  90.             DO I=1,ipt3.NUM(/1)
  91.                ikil=ICPR(ipt3.NUM(I,J))
  92.                if (ikil.ne.0) ipos(ikil)=ipos(ikil)+1
  93.             ENDDO
  94.          ENDDO
  95.       ENDDO
  96.       imaxel=ipos(1)
  97.       i_z = ipos(1)
  98.       DO 13 i = 2, nno2
  99.          imaxel=max(imaxel,ipos(i))
  100.          i_z = i_z + ipos(i)
  101.          ipos(i) = i_z
  102.  13   CONTINUE
  103.       nlel = ipos(nno2)
  104.       ipos(nno2+1) = nlel
  105.       segini,izone
  106.       segini,inum
  107.       DO isous=1,nbsou1
  108.          ipt3=imail(isous)
  109.          DO J=1,ipt3.NUM(/2)
  110.             DO I=1,ipt3.NUM(/1)
  111.                ikil=ICPR(ipt3.NUM(I,J))
  112.                if (ikil.ne.0) then
  113.                   ide=ipos(ikil)
  114.                   izone(ide)=isous
  115.                   inum(ide)=j
  116.                   ipos(ikil)=ide-1
  117.                endif
  118.             ENDDO
  119.          ENDDO
  120.       ENDDO
  121. c      segprt,ipos
  122. c      write(ioimp,*) 'imaxel=',imaxel
  123. c      segprt,izone
  124. c      segprt,inum
  125. *
  126. *     Pour chaque element de ipt2, on regarde les elements de ipt1 qui
  127. *     le contiennent. On tagge les elements de IPT1 en changeant le
  128. *     signe du 1er noeud.
  129. *
  130.       segini,lizone
  131.       segini,linum
  132.       call actobj(ipt2,'MAILLAGE',1)
  133. *      segprt,ipt2
  134.       ipt4=ipt2
  135.       DO IOB=1,MAX(1,IPT2.LISOUS(/1))
  136.          IF (IPT2.LISOUS(/1).NE.0) IPT4=IPT2.LISOUS(IOB)
  137.          DO 30 IL2=1,IPT4.NUM(/2)
  138.             if (ldbg) write(ioimp,*) 'ipt2 isou element ',iob,il2
  139. * On cherche le noeud de IPT2 avec le plus petit nombre de voisins
  140. * dans IPT1, on saute l'element si un des noeuds n'est pas dans IPT1
  141.             NVOIS=IGRAND
  142.             IPMIN=0
  143.             DO IP2=1,IPT4.NUM(/1)
  144.                ik=ICPR(IPT4.NUM(IP2,IL2))
  145.                nik=ipos(ik+1)-ipos(ik)
  146.                if (ldbg) write(ioimp,*) '  ipt2 noeud ',ip2,IPT4.NUM(IP2
  147.      $              ,IL2),nik
  148.                if (nik.lt.nvois) then
  149.                   nvois=nik
  150.                   ipmin=ip2
  151.                endif
  152.             ENDDO
  153.             if (ipmin.eq.0) goto 30
  154.             ik=ICPR(IPT4.NUM(IPMIN,IL2))
  155.             ideb=ipos(ik)+1
  156.             ifin=ipos(ik+1)
  157.             nik=ifin-ideb+1
  158.             do iik=1,nik
  159.                lizone(iik)=izone(ideb+iik-1)
  160.                linum(iik) =inum(ideb+iik-1)
  161.             enddo
  162.             if (ldbg) write(ioimp,*) '   ipt2 ipmin,nik=',ipmin,nik
  163.             do 300 iik=1,nik
  164.                iz=lizone(iik)
  165.                in=linum(iik)
  166.                if (ldbg) write(ioimp,*) '   iik,iz,in=',iik,iz,in
  167.                DO IP2=1,IPT4.NUM(/1)
  168.                   if (ldbg) then
  169.                      write(ioimp,*) '   ip2,ipmin=',ip2,ipmin
  170.                      write(ioimp,*) '     lizone :',(lizone(ibb),ibb=1
  171.      $                    ,nik)
  172.                      write(ioimp,*) '     linum  :',(linum(ibb),ibb=1
  173.      $                    ,nik)
  174.                   endif
  175.                   if (ip2.ne.ipmin) then
  176.                      lfound=.false.
  177.                      ik=ICPR(IPT4.NUM(IP2,IL2))
  178.                      ideb=ipos(ik)+1
  179.                      ifin=ipos(ik+1)
  180.                      do ie=ideb,ifin
  181.                         iz2=izone(ie)
  182.                         in2=inum(ie)
  183.                         if (iz2.eq.iz.and.in2.eq.in) then
  184.                            lfound=.true.
  185.                            goto 3000
  186.                         endif
  187.                      enddo
  188.  3000                continue
  189.                      if (ldbg) write(ioimp,*) '   iik,iz,in,lfound=',iik
  190.      $                    ,iz,in,lfound
  191.                      if (.not.lfound) then
  192.                         lizone(iik)=0
  193.                         linum(iik)=0
  194.                         goto 300
  195.                      endif
  196.                   endif
  197.                ENDDO
  198.  300        continue
  199.             do iik=1,nik
  200.                iz=lizone(iik)
  201.                in=linum(iik)
  202.                if (iz.ne.0.and.in.ne.0) then
  203.                   ipt3=imail(iz)
  204.                   ipt3.num(1,in)=-abs(ipt3.num(1,in))
  205.                endif
  206.             enddo
  207.  30      CONTINUE
  208.       ENDDO
  209.       segsup lizone
  210.       segsup linum
  211.       segsup izone
  212.       segsup inum
  213.       segsup ipos
  214.       segsup icpr
  215. *
  216. * On reduit de maniere adequate les maillages de imail
  217. *
  218.       nsou2=nbsou1
  219.       nbltot=0
  220. c      segprt,imail
  221.       do isous=1,nbsou1
  222.          ipt3=imail(isous)
  223.          nel=ipt3.num(/2)
  224.          nno=ipt3.num(/1)
  225.          nbref=ipt3.lisref(/1)
  226.          iel2=0
  227.          do iel=1,nel
  228.             if (ipt3.num(1,iel).lt.0) then
  229.                iel2=iel2+1
  230.                ipt3.num(1,iel2)=-ipt3.num(1,iel)
  231.                do ino=2,nno
  232.                   ipt3.num(ino,iel2)=ipt3.num(ino,iel)
  233.                enddo
  234.             endif
  235.          enddo
  236.          if (iel2.eq.0) then
  237.             segsup ipt3
  238.             imail(isous)=0
  239.             nsou2=nsou2-1
  240.          elseif (iel2.le.nel) then
  241.             nbnn=nno
  242.             nbelem=iel2
  243.             nbsous=0
  244.             segadj ipt3
  245.          endif
  246.          nbltot=nbltot+iel2
  247.       enddo
  248. c      write(ioimp,*) 'nsou2=',nsou2
  249.       if (nsou2.eq.0) then
  250.          call melvid(ilcour, meleme)
  251.       elseif (nsou2.eq.1) then
  252.          do isous=1,nbsou1
  253.             if (imail(isous).ne.0) then
  254.                meleme=imail(isous)
  255.                goto 45
  256.             endif
  257.          enddo
  258.  45      continue
  259.       else
  260.          nbnn=0
  261.          nbelem=0
  262.          nbsous=nsou2
  263.          nbref=0
  264.          segini meleme
  265.          isou2=0
  266.          do isous=1,nbsou1
  267.             if (imail(isous).ne.0) then
  268.                isou2=isou2+1
  269.                lisous(isou2)=imail(isous)
  270.                if (isou2.eq.nsou2) goto 55
  271.             endif
  272.          enddo
  273.  55      continue
  274.       endif
  275.       segsup imail
  276. *
  277. * Normal termination
  278. *
  279.       RETURN
  280. *
  281. * End of subroutine ELEMEL
  282. *
  283.       END
  284.  
  285.  

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