Sources Esope | Cast3M

resouc
C RESOUC    SOURCE    MB234859  25/02/17    21:15:11     12155          
      SUBROUTINE RESOUC(MRIGID,MRIGIC,IDEMEM,IDEME0,IDEME1,
     >      NOUNIL,BDBLX,ICOND,IMULT,IF,IMTVID,NELIM)
C----------------------------------------------------------------------
C Subroutine dont le role est de :
C - choisir les ddls a eliminer
C - retirer les ddls elimines des autres rigidites et construire la 
C   rigidite condensee
C - modifier le second membre du fait de l'elimination de ddls
C   (ajout de forces et modification du jeu des relations ou un ddl 
C   elimine intervient)
C
C Les multiplicateurs de Lagrange sont dedoubles.
C
C Entrees :
C ---------
C  mrigid : pointeur sur la rigidite totale
C  idemem : tableau contenant le(s) second(s) membre(s)
C  nounil : vaut 0 si les conditions unilaterales doivent etre 
C           traitees comme telles
C  nelim  : vaut 0 s'il ne faut pas eliminer
C      if : passe d'elimination
C   bdblx : true si il faut dedoubler les mult. de Lagrange
C
C Sorties :
C ---------
C  mrigic : pointeur sur la rigidite condensee
C  ideme0 : tableau contenant pour le(s) second(s) membre(s) les
C           valeurs des secondes membres a la passe d'elimination if
C  ideme1 : tableau contenant pour le(s) second(s) membre(s) les
C           valeurs de chaque condition eliminee a la passe d'elimination if
C  idemem : tableau contenant le(s) second(s) membre(s) apres la 
C           passe d'elimiation if
C  imult  : nombre de ddl(s) elimine(s)
C  icond  : nombre de condition(s) restante(s)
C  imtvid : vaut 1 si la matrice condensee est vide
C
C----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
-INC PPARAM
-INC CCOPTIO
-INC SMRIGID
-INC SMCHPOI
-INC SMELEME
C
      LOGICAL bdblx
C
      segment idemem(0)
      segment ideme0(idemem(/1),30)
      segment ideme1(idemem(/1),30)
C
      segact mrigid
C     write(6,*) ' resouc jrcond ichole ',jrcond,ichole,if
C     -----------------------------------------------------------------
C     Condensation des rigidites
C     -----------------------------------------------------------------
      if (jrcond.eq.0.and.ichole.eq.0) then
C
        call separm(mrigid,ri1,ri2,nounil,bdblx,nelim,if)
        if(ierr.ne.0) return
C
        call fusrig(ri1,ri2,ipoir0)
        if(ierr.ne.0) return
C
        call depen3(ri1,ri6)
        if(ierr.ne.0) return
C
        call scnd3(ri2,ri6,ri3)
        if(ierr.ne.0) return
C
        call dual00(ri6,ri5)
        if(ierr.ne.0) return
C
        segact mrigid*mod
        jrtot=ipoir0
        jrelim=ri1
        jrgard=ri2
        jrcond=ri3
        jrdepd=ri5
        jrdepp=ri6
        lagdua=0
        if (bdblx) then
          lagdua=ri2.imlag
        endif
        imlag=lagdua
        segact ri3*mod
        ri3.jrsup=mrigid
        ri3.imlag=imlag
      else
        ri1=jrelim
        ri2=jrgard
        ri3=jrcond
        ri5=jrdepd
        ri6=jrdepp
        lagdua=imlag
      endif
      mrigic=ri3
      segact,ri3
C     -----------------------------------------------------------------
C     Nombre de ddl elimine
      segact ri1
      imult=0
      if (ri1.irigel(/2).gt.0) then
        do ir=1,ri1.irigel(/2)
          ipt1=ri1.irigel(1,ir)
          segact ipt1
          imult=imult+ipt1.num(/2)
        enddo
      endif
C
C     Nombre de conditions restantes dans ri3
      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     -----------------------------------------------------------------
C     Condensation des second membres
C     -----------------------------------------------------------------
      do 1050 ig=1,idemem(/1)
        ichp2= idemem(ig)
        ideme0(ig,if)=ichp2
*       write(6,*) 'ideme0 ig if ',ideme0(ig,if),ig,if
C       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
*       Si lagdua /= 0, ri2 est deja dualise et il faut dedualiser ichp4
        call dbbcd(ichp4,lagdua)
        if(ierr.ne.0) return
        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
C       ichp1 et ichp2 sont censes etre de nature DISCRETE (JATTRI(1)=2)
        call adchpo(ichp1,ichp2,ichp3,1.D0,1.D0)
        if(ierr.ne.0) return
        if (ichp2.ne.ichp3) call dtchpo(ichp2)
C       Dedoublement des mult de lagrange
        call dbbch(ichp3,lagdua)
*       write(6,*) ' appel dbbch ',lagdua
        if(ierr.ne.0) return
        idemem(ig)=ichp3
1050  CONTINUE
C     -----------------------------------------------------------------
      segdes ri1,ri2,ri3,ri5,ri6,mrigid
      RETURN
      END