Esope source files

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