Sources Esope | Cast3M

rfco
C RFCO      SOURCE    PV090527  25/03/25    21:15:05     10831          
      SUBROUTINE RFCO
*----------------------------------------------------------------------
*  Calcul des raideurs et des jeux dans le cas de modeles de contact
*  avec ou sans frottements
*
*  Entree : MMODEL de contact
*
*  Sortie : CHPOINT (valeurs des jeux) (pas pour les frocable)
*           RIGIDITE conditions de contact et de frottements
*
*  Remarque : faut-il egalement sortir les conditions de frottements 
*             pour les utiliser comme indicateur de recalcul des 
*             conditions en cas de grands glissements. 
*             Les lignes commentees demarrant apr CCC permettent de   
*             faire cela mais a tester davantage avant
*----------------------------------------------------------------------
C
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C
-INC PPARAM
-INC CCOPTIO
-INC SMMODEL
      pointeur mmode3.mmodel,imode3.imodel
-INC SMRIGID
-INC SMCHPOI
-INC SMELEME
-INC SMCOORD
C
      logical lconv
C
      CALL LIROBJ('MMODEL  ',MMODEL,1,IRETOU)
      CALL ACTOBJ('MMODEL  ',MMODEL,1)
      IF(IERR.NE.0) RETURN
C
      CALL LIRLOG(lconv,1,iretou)
C
      MCHELX=0
      CALL LIROBJ('MCHAML  ', MCHELX,0,IRCHA1)
      IF(IRCHA1.EQ.1) CALL ACTOBJ('MCHAML  ', MCHELX,1)
      IF(IERR.NE.0) RETURN
C
      segact mcoord
      irigi0=0
      irigi1=0
      irigi2=0
      mforc=0
C
      DO 10 ISOUS=1,KMODEL(/1)
        imodel=kmodel(isous)
        if (formod(1).NE.'CONTACT') GOTO 10
C
C       D'apres NOMATE :
C       imate=1 unilateral; imate=2 maintenu; 
C       inatu=0 sans frottement;inatu=1 coulomb; inatu=2 frocable
C
C       CONTACT UNILATERAL
        if(imatee.eq.1) then
C
C         FROCABLE
          if(inatuu.eq.2) then
            if (lconv) then
**            write(6,*) ' ivamod ',ivamod(/1)
              if(ivamod(/1).ne.3) call erreur(5)
              ri3 = 0
              meleme = ivamod(2)
              ipt1   = ivamod(1)
*             call ecmail( meleme,1)
*             call ecmail ( ipt1,1)
*             Petit modele unitaire local (a detruire en fin de traitement)
              n1=1
              segini,mmode2,mmode3
              nfor=0
              nmat=0
              mn3=1
              nobmod=1
              segini imode2
              imode2.imamod=imamod
              imode2.conmod=conmod
              imode2.ivamod(1)=mmode3
              imode2.tymode(1)='MMODEL'
              mmode2.kmodel(1)=imode2
              nobmod=0
              segini imode3
              imode3.imamod=ipt1
              imode3.conmod=conmod
              mmode3.kmodel(1)=imode3
*             Option accro 'GLISS'
              igliss=1
              call ecrree(1.d-3)
              call ecrobj('MAILLAGE',meleme)
              call ecrobj('MMODEL  ',mmode2)
              call accro(igliss)
              if (ierr.ne.0) goto 9000
              call lirobj('RIGIDITE',ri2,1,iretou)
              if (ierr.ne.0) goto 9000
              segsup mmode2,mmode3
              if(irigi2.eq.0) then
                irigi2=ri2
              else
                call fusrig(irigi2,ri2,Inoup)
                irigi2= inoup
              endif
            endif
C
          else
C           Cas sans frottement ou avec frottement de Coulomb
            ipt1   = imamod
            ipt6   = ivamod(1)
            ipt8   = ivamod(2)
            itcont = ivamod(3)
C
            if(idim.eq.3) then
**            write(6,*) ' avant impo32 ipt6 ipt8 itcont inatuu',
**   >        ipt6,ipt8,itcont,inatuu
              call impo32(ipt1,ipt6,ipt8,itcont,mchelx,ri1,mchpo2)
              if (ierr.ne.0) return
C--------------------------------------------------------------------
CCC           if (mchpo2.ne.0) call frig3C(ipt1,ri1,mchpo2,ri2)
C--------------------------------------------------------------------
              if (inatuu.eq.1.and.mchpo2.ne.0) then 
                call frig3C(ipt1,ri1,mchpo2,ri2)
                if (ierr.ne.0) return
              endif
            endif
C
            if(idim.eq.2) then
              if (ifomod .ne. -1 .and. ifomod .ne. 0) then
                call erreur(710)
                return
              endif
**            write(6,*) ' appel impos2 '
              call impos2(ipt1,ipt6,ipt8,itcont,mchelx,ri1,mchpo2)
              if (ierr.ne.0) return
C--------------------------------------------------------------------
CCC           if (mchpo2.ne.0) call frig2C(ipt1,ri1,mchpo2,ri2)
C--------------------------------------------------------------------
              if (inatuu.eq.1.and.mchpo2.ne.0) then 
                call frig2C(ipt1,ri1,mchpo2,ri2)
                if (ierr.ne.0) return
              endif
            endif
C
            call ftaill(ipt1,mchpo2)
            if (ierr.ne.0) goto 9000
C
C           Fusionner les objets pour le modele elementaire courant
            ri3=ri1
            if (inatuu.eq.1.and.mchpo2.ne.0) call fusrig(ri1,ri2,ri3)
C
C--------------------------------------------------------------------
C           Fusionner les objets avec les autres modeles elementaires
CCC         if(irigi0.eq.0.or.ri2.eq.0) then
CCC           irigi0=irigi0+ri2
CCC         else
CCC           call fusrig(irigi0,ri2,inoup)
CCC           irigi0=inoup
CCC         endif
C--------------------------------------------------------------------
C
C           Fusionner les objets avec les autres modeles elementaires
            if(irigi1.eq.0) then
              irigi1=ri3
            else
              call fusrig(irigi1,ri3,inoup)
              irigi1=inoup
            endif
C
            if(mforc.eq.0.or.mchpo2.eq.0) then
              mforc=mforc+mchpo2
            else
              call adchpo(mchpo2,mforc,iret,1.D0,1.D0)
              mforc=iret
            endif
C
          endif
C
        endif
  10  CONTINUE
C
C     IRIGI2 : Pointeur sur les rigidites des modeles FROCABLES
C     IRIGI1 : Pointeur sur les rigidites des autres modeles
*  on reordonne mrigid pour mettre en premier toutes
*  les relations unilatérales ( frocables peut en sortir des pas unil)
      mrigid=irigi1
      if(irigi2.ne.0) then
        mrigid=irigi2
        segini,ri1=mrigid
        ide=0
        segact mrigid
        ifi=irigel(/2)+1
        do i=1,irigel(/2)
          if( irigel(6,i). eq .0) then
            ifi=ifi-1
            ipla=ifi
          else
           ide=ide+1
            ipla=ide
          endif
          do ib=1,irigel(/1)
            ri1.irigel(ib,ipla)=irigel(ib,i)
          enddo
          ri1.coerig(ipla)= coerig(i)
        enddo
        segdes ri1
****    segsup mrigid
        mrigid=ri1
*  une seule raideur en sortie
        if (ri1.eq.0.or.irigi1.eq.0) then
          mrigid = ri1+irigi1
        else
          call fusrig(ri1,irigi1,mrigid)
        endif
      endif
C
C--------------------------------------------------------------------
C     Conditions de frottement : pour tests dans unpas
CCC   if(irigi0.eq.0) then
CCC     call ecrent(irigi0)
CCC   else
CCC     call actobj('RIGIDITE',irigi0,0)
CCC     call ecrobj('RIGIDITE',irigi0)
CCC   endif
C--------------------------------------------------------------------
C
      if(mrigid.eq.0) then
        call ecrent(mrigid)
      else
        call actobj('RIGIDITE',mrigid,0)
        call ecrobj('RIGIDITE',mrigid)
      endif
C
      if(mforc.eq.0) then
         call ecrent(mforc)
      else
         call actobj('CHPOINT',mforc,1)
         call ecrobj('CHPOINT',mforc)
      endif
C
      RETURN
C
 9000 CONTINUE
      CALL ERREUR (19)
      END