Télécharger la plaquette Cast3M


fr en

Télécharger dbbsup.eso

Retour à la liste

Numérotation des lignes : 

dbbsup

  1. C DBBSUP    SOURCE    PV        21/01/29    21:15:17     10866          
  2. C  suppression des doubles multiplicateurs de L sur une restitution
  3. C
  4.       subroutine dbbsup(icolac)
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8 (A-H,O-Z)
  7. -INC TMCOLAC
  8. -INC SMELEME
  9. -INC SMRIGID
  10. -INC SMCHPOI
  11. -INC SMCOORD
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15.       segment trav
  16.        integer lag1(nbpts)
  17.        integer lag2(nbpts)
  18.       endsegment
  19.  
  20.       write (6,*) ' fusion des doubles multiplicateurs de Lagrange'
  21.       segini trav
  22.       nbnn=2
  23.       nbelem=0
  24.       nbsous=0
  25.       nbref=0
  26.       segini ipt8
  27.       ipt8.itypel=2
  28.       segact icolac
  29. *
  30. *  on construit d'abord le meleme des couples de multiplicateurs
  31. *
  32.       ITLACC=KCOLA(1)
  33.       segact itlacc
  34.       IF (ITLAC(/1).EQ.0) GOTO 20
  35.       DO 12 I=1,ITLAC(/1)
  36.        MELEME=ITLAC(I)
  37.        IF (meleme.eq.0) goto 12
  38.        segact meleme*mod
  39.        if (itypel.ne.49) then
  40.         segdes meleme
  41.         goto 12
  42.        endif
  43. *  ok on supprime le 2eme noeud
  44.        nbele=num(/2)
  45.        nbelem=nbelem+nbele
  46.        nbnn=2
  47.        segadj ipt8
  48.        do 30 ie=1,nbele
  49.        ipt8.num(1,nbelem-nbele+ie)=num(1,ie)
  50.        ipt8.num(2,nbelem-nbele+ie)=num(2,ie)
  51.        lag1(num(1,ie))=num(2,ie)
  52.        lag2(num(2,ie))=num(1,ie)
  53. *      do 40 in=2,num(/1)-1
  54. *       num(in,ie)=num(in+1,ie)
  55. * 40   continue
  56.   30   continue
  57. *      nbelem=num(/2)
  58. *      nbnn=num(/1)-1
  59. *      segadj meleme
  60.        segdes meleme
  61.   12   continue
  62.    20  continue
  63. *  on elimine dans les chpoint
  64.        itlacc=kcola(2)
  65.        segact itlacc
  66.        if (itlac(/1).eq.0) goto 90
  67.        do 100 i=1,itlac(/1)
  68.        mchpoi=itlac(i)
  69.        segact mchpoi
  70.        do 110 isoupo=1,ipchp(/1)
  71.         msoupo=ipchp(isoupo)
  72.         segact msoupo
  73.         if (nocomp(/2).ne.1) goto 110
  74.         mul=0
  75.         if (nocomp(1).eq.'LX') mul=2
  76.         if (nocomp(1).eq.'FLX') mul=1
  77.         if (mul.eq.0) goto 110
  78.         write (6,*) ' conversion du mpoval ',ipoval,nocomp(1)
  79.         meleme=igeoc
  80.         segact meleme
  81.         mpoval=ipoval
  82.         segact mpoval*mod
  83.         ict=0
  84.         do 130 iv=1,vpocha(/1)
  85.           if (lag2(num(1,iv)).ne.0) goto 130
  86.           val=vpocha(iv,1)
  87.           if (lag1(num(1,iv)).ne.0) val=mul*val
  88.           ict=ict+1
  89.           vpocha(iv,1)=val
  90.  130    continue
  91.         n=ict
  92.         nc=1
  93.         segadj mpoval
  94.         segdes mpoval,meleme
  95.  110  continue
  96.  100  continue
  97.   90  continue
  98. *  on élimine dans les raideurs
  99.       itlacc=kcola(3)
  100.       segact itlacc
  101.       if (itlac(/1).eq.0) goto 290
  102.       do 300 i=1,itlac(/1)
  103.       mrigid=itlac(i)
  104.       segact mrigid
  105.       do 310 ir=1,irigel(/2)
  106.       descr=irigel(3,ir)
  107.       segact descr*mod
  108.       if (lisinc(2).ne.'LX') goto 311
  109.       write (6,*) 'conversion de la raideur ',mrigid,ir
  110.       do 320 il=2,lisinc(/2)-1
  111.        lisinc(il)=lisinc(il+1)
  112.        lisdua(il)=lisdua(il+1)
  113.        noelep(il)=noelep(il+1)-1
  114.        noeled(il)=noeled(il+1)-1
  115.  320  continue
  116.       nligrp=lisinc(/2)-1
  117.       nligrd=nligrp
  118.       segadj descr
  119.       xmatri=irigel(4,ir)
  120.       segact xmatri*mod
  121.           nelrig=re(/3)
  122.           if (re(/1).ne.nligrd) then
  123.           segadj xmatri
  124.       do 330 im=1,nelrig
  125. *      xmatri=imattt(im)
  126. *      segact xmatri*mod
  127. *  test si le xmatri a déjà été converti
  128.       if (re(/1).eq.nligrd) goto 341
  129.       do     il=1,nligrd
  130.       do     ic=1,nligrd
  131.       re(il,ic,im)=re(il+1,ic+1,im)
  132.       enddo
  133.       enddo
  134.       re(1,1,im)=0.d0
  135. *      segadj xmatri
  136.  341  continue
  137. *      segdes xmatri
  138.  330  continue
  139.       endif
  140.       segdes xmatri
  141.  311  continue
  142.       segdes descr
  143.  310  continue
  144.       segdes mrigid
  145.  300  continue
  146.  290  continue
  147. *  on elimine dans les maillages en dernier
  148.       itlacc=kcola(1)
  149.       segact itlacc
  150.       if (itlac(/1).eq.0) goto 190
  151.       do 200 i=1,itlac(/1)
  152.        meleme=itlac(i)
  153.        segact meleme*mod
  154.        if (itypel.ne.1 ) goto 210
  155.        ict=0
  156.        do 220 j=1,num(/2)
  157.          if (lag2(num(1,j)).ne.0) goto 220
  158.          ict=ict+1
  159.          num(1,ict)=num(1,j)
  160.  220   continue
  161.        if (nbelem.ne.ict)
  162.      >   write (6,*) ' conversion du meleme poin1 ',meleme
  163.        nbnn=1
  164.        nbelem=ict
  165.        nbsous=0
  166.        nbref=0
  167.        segadj meleme
  168.  210   continue
  169.        if (itypel.ne.49) goto 230
  170.        write (6,*) ' conversion du meleme type 22 ',meleme
  171.        do     j=1,num(/2)
  172.        do     ip=num(/1)-1,2,-1
  173.         num(ip,j)=num(ip+1,j)
  174.        enddo
  175.        enddo
  176.        nbnn=num(/1)-1
  177.        nbelem=num(/2)
  178.        nbsous=0
  179.        nbref=0
  180.        segadj meleme
  181.  230   continue
  182.        segdes meleme
  183.  200  continue
  184.  190  continue
  185.       segsup trav
  186. *
  187.        return
  188.        end
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  

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