Télécharger la plaquette Cast3M


fr en

Télécharger part4.eso

Retour à la liste

Numérotation des lignes : 

part4

  1. C PART4     SOURCE    PASCAL    20/01/14    21:15:30     10496          
  2. *  partitionne meleme dans itab en fonction du contenu de ipos
  3. *
  4.       SUBROUTINE PART4(MELEME,IPOS,ICPR,NB,ITAB,IADJ,JADJC,KESCL)
  5. *
  6.       IMPLICIT INTEGER(I-N)
  7. -INC SMELEME
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11.       segment ifait(2**nb)
  12.       segment ipos(0)
  13.       segment icpr(0)
  14.       segment iadj(0)
  15.       segment jadjc(0)
  16.       CALL CRTABL(ITAB)
  17.       IF (KESCL.GT.0) THEN
  18.          CALL ECCTAB(ITAB,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,
  19.      #                     0,'MOT',0,0.D0,'ESCLAVE',.TRUE.,0)
  20.          CALL ECCTAB(ITAB,'MOT',0,0.D0,'CREATEUR',.TRUE.,
  21.      #                     0,'MOT',0,0.D0,'PART',.TRUE.,0)
  22.       ENDIF
  23.   90  continue
  24.       segini ifait
  25.       nodes=ipos(/1)/3
  26.       nbelan=0
  27.       nbelno=0
  28. *  boucle sur les zones de maillages à creer
  29.       izr=0
  30.       do 10 iz=1,2**nb
  31.       segact meleme
  32.       nbnn=0
  33.       nbelem=0
  34.       nbref=0
  35.       nbsous=max(1,lisous(/1))
  36.       segini,ipt4
  37.       jsous=0
  38.       ipt1=meleme
  39.       do 20 isous=1,max(1,lisous(/1))
  40.       if (lisous(/1).ne.0) ipt1=lisous(isous)
  41.       segact ipt1
  42.       if (iz.eq.1) nbelan=nbelan+ipt1.num(/2)
  43.       segini,ipt5=ipt1
  44.       do 30 j=1,ipt5.num(/2)
  45.       ifro=1
  46.       do 40 i=1,ipt5.num(/1)
  47.         ip=icpr(ipt5.num(i,j))
  48.         if (ipos(2*nodes+ip).lt.nb) goto 40
  49.         ifro=0
  50.         if (ifait(iz).eq.0) then
  51.           do k=1,iz-1
  52.            if (ifait(k).eq.ipos(nodes+ip)) goto 35
  53.           enddo
  54.           ifait(iz)=ipos(nodes+ip)
  55.         endif
  56. *       write (6,*) ' itypel ifait ipos ',ipt5.itypel,ifait(iz),
  57. *    >     ipos(nodes+ip),ipos(2*nodes+ip)
  58.         if (ifait(iz).eq.ipos(nodes+ip)) goto 37
  59.   40  continue
  60.       if (ifro.eq.1) then
  61. *     write (6,*) ' ifro 1 ',ifro
  62. * embetant tous les noeuds sont sur la frontiere
  63. * recherche de la zone voisine la plus grande
  64.        izone=0
  65. *      write (6,*) ' element sur la frontiere ',ipt5.num(/1)
  66.  
  67.        do 60 i=1,ipt5.num(/1)
  68.         ip=icpr(ipt5.num(i,j))
  69.         do 65 iv=iadj(ip),iadj(ip+1)-1
  70.          K=JADJC(iv)
  71. *        write (6,*) ' noeud ',ip,' vois ',k,' zone ',ipos(2*nodes+k),
  72. *    >  'nb ',nb
  73.          if (ipos(2*nodes+k).lt.nb) goto 65
  74.          izone=max(izone,ipos(nodes+k))
  75.   65    continue
  76.   60   continue
  77.        if (izone.eq.0) then
  78. *      write (6,*) 'izone 0 apres 60 '
  79. * on essaye un peu plus loin
  80.        do 80 i=1,ipt5.num(/1)
  81.         ip=icpr(ipt5.num(i,j))
  82.         do 85 iv=iadj(ip),iadj(ip+1)-1
  83.           ivv=jadjc(iv)
  84.           do 86 iw=iadj(ivv),iadj(ivv+1)-1
  85.             K=JADJC(iw)
  86. *           write (6,*) 'noeud ',ip,' vois ',k,' zone ',ipos(2*nodes+k),
  87. *    >      'nb ',nb
  88.             if (ipos(2*nodes+k).lt.nb) goto 86
  89.             izone=max(izone,ipos(nodes+k))
  90.   86      continue
  91.   85    continue
  92.   80   continue
  93.         if (izone.eq.0) call erreur(920)
  94.         if (ierr.ne.0) return
  95.        endif
  96.         if (ifait(iz).eq.0) then
  97.           do k=1,iz-1
  98.            if (ifait(k).eq.izone) goto 35
  99.           enddo
  100.           ifait(iz)=izone
  101.         endif
  102.        if (izone.eq.ifait(iz)) goto 37
  103.       endif
  104.   35  continue
  105. * on annule l'element
  106.       ipt5.num(1,j)=0
  107.   37  continue
  108.   30  continue
  109. *  compaction de ipt5
  110.       jf=0
  111. *     write (6,*) 'avant compaction ipt5 itypel nbel',ipt5.itypel,
  112. *    >  ipt5.num(/2)
  113.       do 50 j=1,ipt5.num(/2)
  114.       if (ipt5.num(1,j).eq.0) goto 50
  115.       jf=jf+1
  116.       ipt5.icolor(jf)=ipt5.icolor(j)
  117.       do i=1,ipt5.num(/1)
  118.         ipt5.num(i,jf)=ipt5.num(i,j)
  119.       enddo
  120.   50  continue
  121.       nbnn=ipt5.num(/1)
  122.       nbelem=jf
  123.       nbelno=nbelno+nbelem
  124.       nbsous=0
  125.       nbref=0
  126.       segadj ipt5
  127. *     write (6,*) 'apres compaction ipt5 itypel nbel',ipt5.itypel,
  128. *    >  ipt5.num(/2)
  129.       segdes ipt5
  130.       if (jf.ne.0) then
  131.         jsous=jsous+1
  132.         ipt4.lisous(jsous)=ipt5
  133.       else
  134.         segsup ipt5
  135.       endif
  136.       segdes ipt1
  137.   20  continue
  138.       nbsous=jsous
  139.       nbref=0
  140.       nbnn=0
  141.       nbelem=0
  142.       segadj ipt4
  143.       if (jsous.eq.1) then
  144.          ipt5=ipt4.lisous(1)
  145.          segsup ipt4
  146.          ipt4=ipt5
  147.       endif
  148.       segdes meleme,ipt4
  149.       if (jsous.eq.0) goto 10
  150.       izr=izr+1
  151.       CALL ECCTAB(ITAB,'ENTIER',izr,0.D0,' ',.TRUE.,
  152.      #                   0,'MAILLAGE',0,0.D0,' ',.TRUE.,ipt4)
  153.   10  continue
  154.       if (nbelno.ne.nbelan) call erreur(920)
  155.       segsup ifait,ipos,icpr,iadj,jadjc
  156.       end
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  

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