Esope source files

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