Sources Esope | Cast3M

kres6b
C KRES6B    SOURCE    GOUNAND   25/04/30    21:15:16     12258          
      SUBROUTINE KRES6B(IPOIRI,IDEMEM,IDEME0,IDEME1,NELIMV,
     $        MRIGIC,ICOND,NPASS)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : KRES6B
C DESCRIPTION : Effectue la condensation des relations
C               Repris de resou.eso
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C VERSION    : v1, 09/04/2025, version initiale
C HISTORIQUE : v1, 09/04/2025, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC SMRIGID
-INC SMCHPOI
-INC SMELEME
*
      PARAMETER (NELMAX=30)
      SEGMENT IDEMEM(0)
      segment ideme0(idemem(/1),NELMAX)
      segment ideme1(idemem(/1),NELMAX)
      logical bdblx
*
      NOUNIL=1
      NOEN=1
      NELIM=NELIMV
      IGRADJ=1
      MRIGIC=IPOIRI
C      write(ioimp,*) 'NELIM=',NELIM
C
C Recopie
C
C     Verifier qu'il n'y a pas de blocage en double
***   call verlag(ipoiri)
      if (ierr.ne.0) return
*     y a t il des matrices de relations non unilaterales
      mrigid=ipoiri
C     call prrigi(ipoiri,1)
      segact mrigid
      ifochs=iforig
      idepe=0
*     write(ioimp,*) 'dans resou mrigid iforig ',mrigid,iforig
C
      nbr = irigel(/2)
      if (jrcond.ne.0) nelim=nelmax
      do 1000 irig = 1,nbr
         meleme=irigel(1,irig)
         segact meleme
         if ((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22)
     >        idepe=idepe+num(/2)
         if (irigel(6,irig).ne.0) iunil=1
*!       if (irigel(6,irig).eq.2) nelim=nelmax
         if (irigel(7,irig).ne.0) then
            insym=1
            ichski=0
         endif
 1000 continue
*      write(ioimp,*) 'idepe=',idepe
*      write(ioimp,*) 'iimpi=',iimpi
C
C     Elimination recursive des conditions aux limites
*  on la fait en gradient conjugue ou en appel de unilater
*!      if (igradj.eq.1.or.(iunil.eq.1.and.nounil.eq.0)) nelim=nelmax
      nfois=nelim-1
      bdblx=.false.
      imult=1
      icond=idepe
      icondi=(icond*10)/9+1
      if=0
      do ifois=1,nfois
         if(imult.ne.0.and.icond.ne.0.and.(icond*10)/9.lt.icondi.and.
     >        (icondi-icond.gt.0.or.igradj.eq.1)) then
            icondi=icond
            if=if+1
            if(ierr.ne.0) return
            call resouc(mrigid,mrigic,idemem,ideme0,ideme1,
     >           nounil,bdblx,icond,imult,if,imtvid,nelim)
            if (iimpi.ne.0) write(ioimp,*) ' passe ',if,' condition '
     $           ,icond
            if(ierr.ne.0) return
            mrigid=mrigic
*            call ecrobj('RIGIDITE',mrigid)
*            ismbrc=idemem(1)
*            call ecrobj('CHPOINT',ismbrc)
*            call prlist
         endif
      enddo
C
C     S'il reste des conditions : dedoubler les mult de Lagrange restants
C     -> nouvel appel pour creer lagdua et adapter les seconds membres
      if (iunil.eq.0.or.nounil.eq.1) then
         if (icond.ne.0) then
            if=if+1
            bdblx=.true.
            if(ierr.ne.0) return
            call resouc(mrigid,mrigic,idemem,ideme0,ideme1,
     >           nounil,bdblx,icond,imult,if,imtvid,nelim)
            if (iimpi.ne.0) write(ioimp,*) ' passe ','finale'
     $           ,' condition ',icond
            if(ierr.ne.0) return
            mrigid=mrigic
*            call ecrobj('RIGIDITE',mrigid)
*            ismbrc=idemem(1)
*            call ecrobj('CHPOINT',ismbrc)
*            call prlist
         endif
      endif
      if (iimpi.ne.0) then
         segact mrigid
         write (ioimp,*) 'nombre de passes, imlag',if,mrigid.imlag
      endif
      if (idepe.ne.0) noid=1
C
C Fin recopie
C
      NPASS=if
      RETURN
*
* End of subroutine KRES6B
*
      END