Sources Esope | Cast3M

resouc
C RESOUC    SOURCE    PV090527  23/09/13    21:15:03     11739          
      subroutine resouc(mrigid,mrigic,idemem,ideme0,ideme1,
     >      nounil,lagdua,icond,imult,if,imtvid,nelim)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C **** Eliminiation des relations dans une raideur
C **** mrigic est la raideur resultante
C      icond dit si on a reussi a condense qque chose
C      imult dit si il reste des multiplicateurs non condensees
C      Ensuite reduction des seconds membres
C
-INC SMRIGID
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMELEME
      segment idemem(0)
      segment ideme0(idemem(/1),30)
      segment ideme1(idemem(/1),30)
C  on va separer les raideurs
      segact mrigid
      if (jrcond.eq.0.and.ichole.eq.0) then
       call separm(mrigid,ri1,ri2,nounil,lagdua,nelim,if)
         if(ierr.ne.0) return
       segact ri1*mod
       segact ri2*mod
*      write(6,*) 'resouc ri1 ',ri1.mtymat
*      write(6,*) 'resouc ri2 ',ri2.mtymat
       if (ri1.ne.mrigid) ri1.mtymat='TEMPORAI'
*xx    ri2.mtymat='TEMPORAI'
       segact mrigid*mod
       jrelim=ri1
       jrgard=ri2
       imlag=max(0,lagdua)
*      write(6,*) ' if lagdua ',if,lagdua
       call fusrig(ri1,ri2,ipoir0)
         if(ierr.ne.0) return
       jrtot=ipoir0
      else
       ri1=jrelim
       ri2=jrgard
       ipoir0=jrtot
       lagdua=imlag
       ipt1=lagdua
       if (ipt1.ne.0) segact ipt1
      endif
      iri1s=ri1
      iri2s=ri2
C
1010  continue
C
*    mrigid matrice complete
*    ri1    dependance
*    ri2    les autres matrices
*    ri6    matrice de transfert
*    ri3    matrice reduite
*    ri5    matrice de transfert transposee
C
C   on va proceder  a la condensation rigidite puis forces
*      write(6,*) ' resouc jrcond ichole ',jrcond,ichole
       if(jrcond.eq.0.and.ichole.eq.0) then
 
         CALL DEPEN3(RI1,RI6)
         if(ierr.ne.0) return
*      write(6,*) 'resouc ri6 ',ri6.mtymat
         segact ri6*mod
         if (ri6.ne.mrigid) ri6.mtymat='TEMPORAI'
         call scnd2 (ri2,ri6,ri3)
         if(ierr.ne.0) return
         segact ri3*mod
*      write(6,*) 'resouc ri3 ',ri3.mtymat
         if (ri3.ne.mrigid) ri3.mtymat='TEMPORAI'
         if(ierr.ne.0) then
         segsup ri1,ri2,ri6
         return
         endif
 
         segact mrigid*mod
         jrcond=ri3
         JRDEPP=RI6
C     dualisation  de la (les) matrice(s) de dependance
         call dual00(ri6,ri5)
         if(ierr.ne.0) return
*      write(6,*) 'resouc ri5 ',ri5.mtymat
         if (ri5.ne.mrigid) then
           segact ri5*mod
            ri5.mtymat='TEMPORAI'
         endif
         jrdepd=ri5
         ipoiri = ri3
       else
         ipoiri= jrcond
         RI6   = JRDEPP
         ri5   = jrdepd
       endif
*  test si on a condense quelque chose
         segact ri1
         imult=ri1.irigel(/2)
         if (ri1.irigel(/2).gt.0) then
          imult=0
          do ir=1,ri1.irigel(/2)
          ipt1=ri1.irigel(1,ir)
          segact ipt1
*          if (ipt1.itypel.eq.22) then
          imult=imult+ipt1.num(/2)
          enddo
         endif
 
 
*  test si il reste des multiplicateurs dans ri3
         segact mrigid
         ri3=jrcond
         segact ri3*mod
         icond=0
         if (ri3.irigel(/2).eq.0) then
           imtvid=1
*          write(6,*) ' matrice vide ri3 '
         endif
         do ir=1,ri3.irigel(/2)
          ipt3=ri3.irigel(1,ir)
          segact ipt3
          if (ipt3.itypel.eq.22) icond=icond+ipt3.num(/2)
         enddo
C
*
      ri3.jrsup=mrigid
      mrigic = ri3
* maintenant reduction des second membres
* en cas de contacts on ne dualise pas . Ce sera fait dans unilater
      ifrot=0
      SEGACT MRIGID*MOD
      DO  I=1,IRIGEL(/2)
       IF(IRIGEL(6,I).ne.0) ifrot=1
      enddo
      if (nounil.eq.1) ifrot=0
      if (lagdua.gt.0) then
      ipt8=lagdua
      if (ierr.ne.0) return
      segact ipt8
      endif
      do 1050 ig=1,idemem(/1)
      ichp2= idemem(ig)
      ideme0(ig,if)=ichp2
*     write(6,*) 'ideme0 ig if ',ideme0(ig,if),ig,if
*  transferer les valeurs imposees des relations sur les inconnues (à éliminer)
      call transr(ichp2,ri1,ichp3)
         if(ierr.ne.0) return
      ideme1(ig,if)=ichp3
*     write(6,*) 'ideme1 ig if ',ideme1(ig,if),ig,if
      call mucpri(ichp3,ri2,ichp4)
         if(ierr.ne.0) return
*  ri2 est deja dualise. Il faut donc dedualiser ichp4
      if (lagdua.gt.0) then
      call dbbcd(ichp4,lagdua)
         if(ierr.ne.0) return
*     write(6,*) ' appel dbbcf ',lagdua
      endif
      call adchpo(ichp2,ichp4,ichp1,1.D0,-1.0D0)
         if(ierr.ne.0) return
      call dtchpo(ichp4)
      call mucpri(ichp1,ri5,ichp2)
         if(ierr.ne.0) return
         mchpo1=ichp1
      mchpo2= ichp1
      segact mchpo2*mod
      mchpo2.jattri(1)=2
      mchpo2= ichp2
      segact mchpo2*mod
      mchpo2.jattri(1)=2
C
      call fuchpo (ichp1,ichp2,ichp3)
         if(ierr.ne.0) return
      if (ichp2.ne.ichp3) call dtchpo(ichp2)
      idemem(ig)=ichp3
*  vecteur a resoudre
*  dualisation des mult de lagrange
      if (lagdua.gt.0.and.ifrot.eq.0) then
      call dbbch(ichp3,lagdua)
         if(ierr.ne.0) return
*     write(6,*) ' appel dbbch ',lagdua
      endif
1050  continue
 
      segdes ri1,ri2,ri3,ri5,ri6,mrigid
      return
      end