Télécharger la plaquette Cast3M


fr en

Télécharger frig2c.eso

Retour à la liste

Numérotation des lignes : 

frig2c

  1. C FRIG2C    SOURCE    MB234859  26/07/24    21:15:01     12606          
  2.  
  3.       SUBROUTINE FRIG2C (maifro,IPRIGI,IPCHJE,IPRIG2)
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8. *  Ce sous-programme calcule la raideur de frottement en 2D.
  9. *  il a besoin pour cela du maillage de frottement et de la raideur
  10. *  de contact (ou la raideur totale si c'est plus simple)
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC CCREEL
  15.  
  16. -INC SMCHPOI
  17. -INC SMELEME
  18. -INC SMRIGID
  19. -INC SMCOORD
  20.  
  21. *  icpr lx du contact   ==> lx du frottement
  22.       segment icpr(nbpts)
  23. *  xjeu champs de jeux initiaux
  24.       segment xjeu(nbpts)
  25. *
  26. *  creation et remplissage de icpr
  27. *
  28.       segini icpr
  29.       nbp=0
  30.       meleme=maifro
  31.       ipt1=meleme
  32.       do is=1,max(1,lisous(/1))
  33.        if (lisous(/1).ne.0) ipt1=lisous(is)
  34.        if (ipt1.itypel.ne.22) call erreur(16)
  35.        if (ierr.ne.0) return
  36.        do iel=1,ipt1.num(/2)
  37.          il=ipt1.num(1,iel)
  38.          if (icpr(il).eq.0) then
  39.           nbp=nbp+1
  40.           icpr(il)=ipt1.num(ipt1.num(/1),iel)
  41.          endif
  42.          if(icpr(il).ne.ipt1.num(ipt1.num(/1),iel)) call erreur(5)
  43.        enddo
  44.       enddo
  45.  
  46. * remplissage du champ de jeux (demi-frottement si jeu non nul)
  47.  
  48.       segini xjeu
  49.       mchpoi = IPCHJE
  50.       iOK=0
  51.       do 15 isoupo = 1, ipchp(/1)
  52.         msoupo = ipchp(isoupo)
  53.         DO 16 i=1,nocomp(/2)
  54.           IF (NOCOMP(i).NE.'FLX ') GOTO 16
  55.           mpoval=ipoval
  56.           ipt8=igeoc
  57.           DO 17 j=1,vpocha(/1)
  58.             xjeu(ipt8.num(1,j))=vpocha(j,i)
  59.   17      CONTINUE
  60.           iOK=1
  61.   16    CONTINUE
  62.   15  continue
  63.       IF (iOK.NE.1) THEN 
  64.         MOTERR(1:4)='FLX '
  65.         MOTERR(5:8)='DEPI'
  66.         CALL ERREUR(77) 
  67.       ENDIF
  68.       IF (ierr.ne.0) return
  69. *
  70. *  boucle sur les raideurs de contact pour les transformer en frottement
  71. *
  72.       mrigid=iprigi
  73.       segact,mrigid
  74.       segini,ri1=mrigid
  75.       do 10 ir=1,irigel(/2)
  76.         ri1.irigel(1,ir)=0
  77.         ri1.irigel(4,ir)=0
  78. CC      if (irigel(6,ir).eq.0)  goto 10
  79.         meleme=irigel(1,ir)
  80.         if (itypel.ne.22) goto 10
  81.         segini,ipt1=meleme
  82.         xmatri=irigel(4,ir)
  83.         segini,xmatr1=xmatri
  84.         do iel=1,ipt1.num(/2)
  85. *  si mult de lagrange pas connu on a 0
  86.          il=ipt1.num(1,iel)
  87.          if=icpr(il)
  88.          ipt1.num(1,iel)=if
  89.          ipt1.icolor(iel)=icolor(iel)
  90.          do ic=2,re(/1),2
  91.           xmatr1.re(1,ic,iel)=-re(1,ic+1,iel)
  92.           xmatr1.re(1,ic+1,iel)=re(1,ic,iel)
  93.           xmatr1.re(ic,1,iel)=-re(ic+1,1,iel)
  94.           xmatr1.re(ic+1,1,iel)=re(ic,1,iel)
  95.          enddo
  96.         enddo
  97.         ri1.irigel(1,ir)=ipt1
  98.         ri1.irigel(4,ir)=xmatr1
  99.         ri1.irigel(6,ir)=2
  100.   10  continue
  101. *
  102. *  boucle de compaction du resultat
  103. *
  104.       mrigid=ri1
  105.       irr=0
  106.       do 100 ir=1,irigel(/2)
  107.        meleme=irigel(1,ir)
  108.        xmatri=irigel(4,ir)
  109.        if (meleme.eq.0) goto 100
  110.        ill=0
  111.        do iel=1,num(/2)
  112.         if (num(1,iel).ne.0) then
  113.          ill=ill+1
  114.          if (ill.ne.0) then
  115.           do in=1,num(/1)
  116.            num(in,ill)=num(in,iel)
  117.           enddo
  118.            icolor(ill)=icolor(iel)
  119.           do ic=1,re(/1)
  120.            re(1,ic,ill)=re(1,ic,iel)
  121.            re(ic,1,ill)=re(ic,1,iel)
  122.           enddo
  123.          endif
  124.         endif
  125.        enddo
  126.        if (ill.eq.0) goto 100
  127.        if (ill.ne.num(/2)) then
  128.         nbsous=0
  129.         nbref=0
  130.         nbnn=num(/1)
  131.         nbelem=ill
  132.         segadj meleme
  133.        endif
  134. **     write (6,*) ' meleme sortie dans frig2c '
  135. **     call ecmail(meleme,0)
  136.  
  137.        irr=irr+1
  138.        if (irr.ne.ir) then
  139.         do ir1=1,irigel(/1)
  140.          irigel(ir1,irr)=irigel(ir1,ir)
  141.         enddo
  142.         coerig(irr)=coerig(ir)
  143.        endif
  144.  100  continue
  145.       nrigel=irr
  146.       if (irigel(/2).ne.irr) segadj mrigid
  147.       iprig2=mrigid
  148.       segsup icpr,xjeu
  149.       return
  150.       end
  151.  
  152.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales