Télécharger la plaquette Cast3M


fr en

Télécharger dbbch.eso

Retour à la liste

Numérotation des lignes : 

dbbch

  1. C DBBCH     SOURCE    CB215821  20/11/25    13:24:04     10792          
  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.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC SMELEME
  11. -INC SMCHPOI
  12. -INC SMCOORD
  13.       segment trav
  14.       integer lag1(nbpts)
  15.       integer lag2(nbpts)
  16.       endsegment
  17. *  ne fonctionne que pour des LX, on suppose qu'il n'y a qu'une include
  18. *  par noeud dédoublé
  19. *  on verifie que le noeud dedouble n'est pas deja dans le champ
  20.       if (ipt8.eq.0) return
  21.       segini trav
  22.       segact mchpoi,ipt8
  23. *     call ecchpo(mchpoi,0)
  24. *     call ecmail(ipt8,0)
  25.       segact mchpoi,ipt8
  26.       do 300 i=1,ipt8.num(/2)
  27.       lag1(ipt8.num(1,i))=ipt8.num(2,i)
  28.  300  continue
  29.       do 310 isoupo=1,ipchp(/1)
  30.       msoupo=ipchp(isoupo)
  31.        segact msoupo
  32.        if (nocomp(/2).ne.1) goto 310
  33.        if (nocomp(1).ne.'FLX') goto 310
  34.        meleme=igeoc
  35.        segact meleme
  36.        do 311 i=1,num(/2)
  37.         lag2(num(1,i))=i
  38.  311   continue
  39.  310  continue
  40.       do 10 isoupo=1,ipchp(/1)
  41.        msoupo=ipchp(isoupo)
  42.        segact msoupo*mod
  43.        if (nocomp(/2).ne.1) goto 10
  44.        if (nocomp(1).ne.'FLX') goto 10
  45.        meleme=igeoc
  46.        mpoval=ipoval
  47.        segact meleme,mpoval*mod
  48.        nbnn=num(/1)
  49.        nbelem=num(/2)
  50.        nbele=nbelem
  51.        nbsous=0
  52.        nbref=0
  53.        segini,ipt1=meleme
  54.        segdes meleme
  55.        meleme=ipt1
  56.        igeoc=meleme
  57. * on fait les meleme et mpoval 2 fois plus grand et ont les ajuste a la fin
  58.        nbelem=nbelem*2
  59.        segadj meleme
  60.        n=nbelem
  61.        nc=1
  62.        segadj mpoval
  63.        nbelem=nbele
  64.        do 100 j=1,nbele
  65.        if (lag1(num(1,j)).eq.0) goto 110
  66. *      write (6,*) ' num lag1 lag2 ',num(1,j),lag1(num(1,j)),
  67. *    > lag2(lag1(num(1,j)))
  68.        if (lag2(lag1(num(1,j))).ne.0) then
  69. *       write (6,*) ' vpocha ',vpocha(j,1),
  70. *    >        vpocha(lag2(lag1(num(1,j))),1)
  71.         interr(1)=lag1(num(1,j))
  72.         interr(2)=lag2(lag1(num(1,j)))
  73.         call erreur(1001)
  74.         goto 110
  75.         endif
  76.         nbelem=nbelem+1
  77.         num(1,nbelem)=lag1(num(1,j))
  78.         vpocha(nbelem,1)=vpocha(j,1)
  79. *     write (6,*) ' noeu ',num(1,j),' valeur ',vpocha(j,1),num(1,nbelem)
  80.         goto 100
  81.  110   continue
  82.  100   continue
  83.         segadj meleme
  84.         n=nbelem
  85.         nc=1
  86.         segadj mpoval
  87.   10   continue
  88.        segsup trav
  89.        return
  90.        end
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  

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