Sources Esope | Cast3M

frig2c
C FRIG2C    SOURCE    SP204843  23/03/09    21:15:03     11621          
 
      SUBROUTINE FRIG2C (maifro,IPRIGI,IPCHJE,IPRIG2)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
*  Ce sous-programme calcule la raideur de frottement en 2D.
*  il a besoin pour cela du maillage de frottement et de la raideur
*  de contact (ou la raideur totale si c'est plus simple)
 
-INC PPARAM
-INC CCOPTIO
-INC CCREEL
 
-INC SMCHPOI
-INC SMELEME
-INC SMRIGID
-INC SMCOORD
 
*  icpr lx du contact   ==> lx du frottement
      segment icpr(nbpts)
*  xjeu champs de jeux initiaux
      segment xjeu(nbpts)
*
*
*  creation et remplissage de icpr
*
      segini icpr
      nbp=0
      meleme=maifro
      ipt1=meleme
      do is=1,max(1,lisous(/1))
       if (lisous(/1).ne.0) ipt1=lisous(is)
       if (ipt1.itypel.ne.22) call erreur(16)
       if (ierr.ne.0) return
       do iel=1,ipt1.num(/2)
         il=ipt1.num(1,iel)
         if (icpr(il).eq.0) then
          nbp=nbp+1
          icpr(il)=ipt1.num(ipt1.num(/1),iel)
         endif
         if(icpr(il).ne.ipt1.num(ipt1.num(/1),iel)) call erreur(5)
       enddo
      enddo
 
* remplissage du champ de jeux (demi-frottement si jeu non nul)
 
      segini xjeu
      mchpoi = IPCHJE
      iOK=0
      do 15 isoupo = 1, ipchp(/1)
        msoupo = ipchp(isoupo)
        DO 16 i=1,nocomp(/2)
          IF (NOCOMP(i).NE.'FLX ') GOTO 16
          mpoval=ipoval
          ipt8=igeoc
          DO 17 j=1,vpocha(/1)
            xjeu(ipt8.num(1,j))=vpocha(j,i)
  17      CONTINUE
          iOK=1
  16    CONTINUE
  15  continue
      IF (iOK.NE.1) THEN 
        MOTERR(1:4)='FLX '
        MOTERR(5:8)='DEPI'
        CALL ERREUR(77) 
      ENDIF
      IF (ierr.ne.0) return
 
 
 
*
*  boucle sur les raideurs de contact pour les transformer en frottement
*
      mrigid=iprigi
      segact,mrigid
      segini,ri1=mrigid
      do 10 ir=1,irigel(/2)
        ri1.irigel(1,ir)=0
        ri1.irigel(4,ir)=0
        if (irigel(6,ir).eq.0)  goto 10
        meleme=irigel(1,ir)
        if (itypel.ne.22) goto 10
        segini,ipt1=meleme
        xmatri=irigel(4,ir)
        segini,xmatr1=xmatri
        do iel=1,ipt1.num(/2)
*  si mult de lagrange pas connu on a 0
         il=ipt1.num(1,iel)
         if=icpr(il)
         ipt1.num(1,iel)=if
         ipt1.icolor(iel)=icolor(iel)
         do ic=2,re(/1),2
          xmatr1.re(1,ic,iel)=-re(1,ic+1,iel)
          xmatr1.re(1,ic+1,iel)=re(1,ic,iel)
          xmatr1.re(ic,1,iel)=-re(ic+1,1,iel)
          xmatr1.re(ic+1,1,iel)=re(ic,1,iel)
         enddo
        enddo
        ri1.irigel(1,ir)=ipt1
        ri1.irigel(4,ir)=xmatr1
        ri1.irigel(6,ir)=2
  10  continue
*
*  boucle de compaction du resultat
*
      mrigid=ri1
      irr=0
      do 100 ir=1,irigel(/2)
       meleme=irigel(1,ir)
       xmatri=irigel(4,ir)
       if (meleme.eq.0) goto 100
       ill=0
       do iel=1,num(/2)
        if (num(1,iel).ne.0) then
         ill=ill+1
         if (ill.ne.0) then
          do in=1,num(/1)
           num(in,ill)=num(in,iel)
          enddo
           icolor(ill)=icolor(iel)
          do ic=1,re(/1)
           re(1,ic,ill)=re(1,ic,iel)
           re(ic,1,ill)=re(ic,1,iel)
          enddo
         endif
        endif
       enddo
       if (ill.eq.0) goto 100
       if (ill.ne.num(/2)) then
        nbsous=0
        nbref=0
        nbnn=num(/1)
        nbelem=ill
        segadj meleme
       endif
**     write (6,*) ' meleme sortie dans frig2c '
**     call ecmail(meleme,0)
 
 
       irr=irr+1
       if (irr.ne.ir) then
        do ir1=1,irigel(/1)
         irigel(ir1,irr)=irigel(ir1,ir)
        enddo
        coerig(irr)=coerig(ir)
       endif
 100  continue
      nrigel=irr
      if (irigel(/2).ne.irr) segadj mrigid
      iprig2=mrigid
      segsup icpr,xjeu
      return
      end