Esope source files

   1 : C DBBCH     SOURCE    PV        13/04/12    21:15:25     7756           
   2 : *  dualise les valeurs d'un champ en fonction d'un meleme de dedoublement de noeuds
   3 : *
   4 :       subroutine dbbch(mchpoi,ipt8)
   5 :       IMPLICIT INTEGER(I-N)
   6 :       IMPLICIT REAL*8 (A-H,O-Z)
   7 : -INC CCOPTIO
   8 : -INC SMELEME
   9 : -INC SMCHPOI
  10 : -INC SMCOORD
  11 :       segment trav
  12 :       integer lag1(xcoor(/1)/(idim+1))
  13 :       integer lag2(xcoor(/1)/(idim+1))
  14 :       endsegment
  15 : *  ne fonctionne que pour des LX, on suppose qu'il n'y a qu'une include
  16 : *  par noeud dédoublé
  17 : *  on verifie que le noeud dedouble n'est pas deja dans le champ
  18 :       if (ipt8.eq.0) return
  19 :       segini trav
  20 :       segact mchpoi,ipt8
  20 : *     call ecchpo(mchpoi,0)
  20 : *     call ecmail(ipt8,0)
  21 :       segact mchpoi,ipt8
  22 :       do 300 i=1,ipt8.num(/2)
  23 :       lag1(ipt8.num(1,i))=ipt8.num(2,i)
  24 :  300  continue
  25 :       do 310 isoupo=1,ipchp(/1)
  26 :       msoupo=ipchp(isoupo)
  27 :        segact msoupo
  28 :        if (nocomp(/2).ne.1) goto 310
  29 :        if (nocomp(1).ne.'FLX') goto 310
  30 :        meleme=igeoc
  31 :        segact meleme
  32 :        do 311 i=1,num(/2)
  33 :         lag2(num(1,i))=i
  34 :  311   continue
  35 :  310  continue
  36 :       do 10 isoupo=1,ipchp(/1)
  37 :        msoupo=ipchp(isoupo)
  38 :        segact msoupo*mod
  39 :        if (nocomp(/2).ne.1) goto 10
  40 :        if (nocomp(1).ne.'FLX') goto 10
  41 :        meleme=igeoc
  42 :        mpoval=ipoval
  43 :        segact meleme,mpoval*mod
  44 :        nbnn=num(/1)
  45 :        nbelem=num(/2)
  46 :        nbele=nbelem
  47 :        nbsous=0
  48 :        nbref=0
  49 :        segini,ipt1=meleme
  50 :        segdes meleme
  51 :        meleme=ipt1
  52 :        igeoc=meleme
  53 :        do 100 j=1,nbele
  54 :        if (lag1(num(1,j)).eq.0) goto 110
  55 : *      write (6,*) ' num lag1 lag2 ',num(1,j),lag1(num(1,j)),
  56 : *    > lag2(lag1(num(1,j)))
  57 :        if (lag2(lag1(num(1,j))).ne.0) then
  58 : *       write (6,*) ' vpocha ',vpocha(j,1),
  59 : *    >        vpocha(lag2(lag1(num(1,j))),1)
  60 :         interr(1)=lag1(num(1,j))
  61 :         interr(2)=lag2(lag1(num(1,j)))
  61 :         call erreur(1001)
  62 :         goto 110
  63 :         endif
  64 :         nbelem=nbelem+1
  65 :         segadj meleme
  66 :         num(1,nbelem)=lag1(num(1,j))
  67 :         n=nbelem
  68 :         nc=1
  69 :         segadj mpoval
  70 :         vpocha(nbelem,1)=vpocha(j,1)
  71 : *     write (6,*) ' noeu ',num(1,j),' valeur ',vpocha(j,1),num(1,nbelem)
  72 :         goto 100
  73 :  110   continue
  74 :  100   continue
  75 :   10   continue 
  76 :        segsup trav
  77 :        return
  78 :        end
  79 : 
  80 :  
  81 :  
  82 :  
  83 :