Télécharger la plaquette Cast3M


fr en

Télécharger rfco.eso

Retour à la liste

Numérotation des lignes : 

rfco

  1. C RFCO      SOURCE    CB215821  24/04/12    21:17:09     11897          
  2.       subroutine rfco
  3.       implicit real*8(a-h,o-z)
  4.       implicit integer (i-n)
  5. *
  6. *  calcul des raideurs et des jeux dans le cas de modeles de contact
  7. *  avec ou sans frottements
  8. * le chpoint existe en cas de contacts ( pas pour les frocable)
  9. *  en sortie : une raideur et un chpoint et une deuxieme raideur.
  10. *  La premiere raideur est celle des contacts, n'existe pas pour frocable
  11. *  la deuxieme raisdeur existe si lconv est vrai et si contact frottant(
  12. *  frocable ou coulomb)
  13. *  si donne d'un chamelem en entree, en sortie le modele et le chamelem reduit sur les contacts retenus
  14. *
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMMODEL
  18.       pointeur mmode3.mmodel,imode3.imodel
  19. -INC SMRIGID
  20. -INC SMCHPOI
  21. -INC SMELEME
  22. -INC SMCOORD
  23.       logical lconv
  24.       call lirobj ('MMODEL  ',mmodel,1,iretou)
  25.       call actobj ('MMODEL  ',mmodel,1)
  26.       if(ierr.ne.0) return
  27.       call lirlog(lconv,1,iretou)
  28.        mchelx=0
  29.        call lirobj('MCHAML  ', mchelx,0,ircha1)
  30. *     write(6,*) 'rfco mchel1 ',mchel1
  31.        if(ircha1.eq.1) call actobj('MCHAML  ', mchelx,1)
  32.       if(ierr.ne.0) return
  33.       segact mcoord
  34.       mrigid=0
  35.       mforc=0
  36.       irigi2=0
  37.       irrr=0
  38.       ifff=0
  39.       irff=0
  40.       nsous= kmodel(/1)
  41.       do isous=1,nsous
  42.         imodel=kmodel(isous)
  43. **      write(6,*) ' boucfle sur modele isous ', isous,imamod
  44. * pour l'instant
  45. * imate=1 unilateral; imate=2 maintenu; inatu=0 pas de frottement
  46. * inatu=1 coulomb; inatu=2 frocable ( voir nomate)
  47.         if( imatee.eq.0) then
  48. * cas de maintenu avec ou sans coulomb  pas encore traité
  49.         elseif(imatee.eq.1) then
  50. * cas de contact unilateral
  51.           if(inatuu.eq.2) then
  52.             if( lconv) then
  53. *cas de frocable
  54. * pour les cables la notion maintenu n'existe pas               ifff=0
  55.               irff=1
  56. *     Petit modele unitaire local (a detruire en fin de traitement)
  57.               n1=1
  58.               segini,mmode2
  59. *     Option accro 'GLISS'
  60.               igliss=1
  61. **            write(6,*) ' ivamod ',ivamod(/1)
  62.               if(ivamod(/1).ne.3) call erreur(5)
  63.               ri2 = 0
  64.               meleme=ivamod(2)
  65.               ipt1= ivamod(1)
  66. *              call ecmail( meleme,1)
  67. *              call ecmail ( ipt1,1)
  68.               nfor=0
  69.               nobmod=1
  70.               mn3=0
  71.               nmat=0
  72.               segini mmode3
  73.               segini imode2
  74.               imode2.imamod=imamod
  75.               imode2.ivamod(1)=mmode3
  76.               imode2.tymode(1)='MMODEL'
  77.               mmode2.kmodel(1)=imode2
  78.               segini imode3
  79.               imode3.imamod=ipt1
  80.               mmode3.kmodel(1)=imode3
  81.               call ecrree(1.d-3)
  82.               call ecrobj('MAILLAGE',meleme)
  83.               call ecrobj('MMODEL  ',mmode2)
  84.               call accro(igliss)
  85.               if (ierr.ne.0) goto 9000
  86.               call lirobj('RIGIDITE',ri2,1,iretou)
  87.               if (ierr.ne.0) goto 9000
  88.               segsup mmode2
  89.               if( irigi2.eq.0) then
  90.                 irigi2=ri2
  91.               else
  92.                 call fusrig(irigi2,ri2,Inoup)
  93.                 irigi2= inoup
  94.               endif
  95.               iraidx=irigi2
  96. * dessous fin du cas frocable
  97.             endif
  98.           else
  99. * cas du frottement de coulomb ou de pas de frottement
  100. *           on commence par le contact unilateral
  101.             ipoin1=imamod
  102.             call ecrobj('MAILLAGE',ipoin1)
  103.             ipt6=0
  104. **          if (inatuu.eq.1) then
  105.               ipt6 = ivamod(1)
  106.               ipt8 = ivamod(2)
  107.               itcont = ivamod(3)
  108.  
  109.               segact ipt6*mod
  110. **          endif
  111.              call ecrent(mchelx)
  112.              call ecrent(isous)
  113. **          write(6,*) ' avant impo32 ipt6 ipt8 itcont inatuu',
  114. **   >        ipt6,ipt8,itcont,inatuu
  115.             if(idim.eq.3) call impo32(ipt6,ipt8,itcont)
  116.             if(idim.eq.2) then
  117.               if (ifomod .ne. -1 .and. ifomod .ne. 0) then
  118.                  call erreur(710)
  119.                  return
  120.               endif
  121. **            write(6,*) ' appel impos2 '
  122.               call impos2(ipt6,ipt8,itcont)
  123.             endif
  124.             call lirobj('RIGIDITE',ri2,1,iretou)
  125.             call lirobj('CHPOINT ',mchpo2,1,iretou)
  126.             call actobj('RIGIDITE',ri2,1)
  127.             call actobj('CHPOINT ',mchpo2,1)
  128.             irrr=1
  129.             ifff=1
  130.             if( mrigid.eq.0) then
  131.                mrigid=ri2
  132.             else
  133.                call fusrig ( ri2 , mrigid, inoup)
  134.                mrigid=inoup
  135.             endif
  136.             iraidx=mrigid
  137.             if( mforc.eq.0) then
  138.                mforc=mchpo2
  139.             else
  140.                call adchpo(mchpo2,mforc,iret,1.d0,1.D0)
  141.                mforc=iret
  142.             endif
  143. ***            if( lconv) then
  144.             if( .true.) then
  145. *    on fait aussi le frottement si on avait convergé.
  146.               if( inatuu.eq.1 ) then
  147.                  if(mchpo2.eq.0) then
  148.                    call erreur (19)
  149.                    return
  150.                  endif
  151.                  ri1=0
  152.                  call lirobj('MCHAML', mchel1,0,ircha1)
  153.                  if (ircha1 .EQ. 1) call actobj('MCHAML', mchel1,1)
  154.                  meleme = imamod
  155.                  if (idim .eq. 3) then
  156.                    call frig3C(meleme,ri2,mchpo2, ri1)
  157.                  else
  158.                    call frig2C(meleme,ri2,mchpo2, ri1)
  159. *                   write(6,*) ' sortie de frig2c ri2 '
  160. *                   call prrigi ( ri2,1)
  161. *                   write(6,*) ' sortie de frig2c ri1'
  162. *                   call prrigi( ri1,1)
  163. *                   write(6,*) ' fin ecrituere apres frig2c'
  164.                  endif
  165. *                write(*,*) 'avant'
  166. *                call ecchpo(mchpo2,0)
  167. **               WRITE(*,*) 'imamod' ,imamod
  168.                  call ftaill(meleme,mchpo2)
  169. **               write(*,*) 'apres'
  170. **               call ecchpo(mchpo2,0)
  171.                  if (ierr.ne.0 .or. ri2.eq.0) goto 9000
  172.                  if(irigi2.eq.0) then
  173.                     irigi2=ri1
  174.                  else
  175.                    call fusrig(irigi2,ri1,inoup)
  176.                    irigi2=inoup
  177.                  endif
  178.               endif
  179.             endif
  180.           endif
  181.         endif
  182.       enddo
  183. **    write(6,*) 'mrigid en 183',mrigid
  184. *
  185. *  on reordonne mrigid pour mettre en premier toutes
  186. *  les relations unilatérales ( frocables peut en sortir des pas unil)
  187. *
  188. *  la premiere raideur ne contient que des relations unilaterales pour
  189. * l'instant
  190. * la deuxieme continet aussi les relations normales d'encasdtrement des
  191. * cables glissants
  192.       iraid1=mrigid
  193.       mrigid=irigi2
  194.       if( mrigid.ne.0) then
  195.         segini,ri1=mrigid
  196.         ide=0
  197.         segact mrigid
  198.         ifi=irigel(/2)+1
  199.         do i=1,irigel(/2)
  200.           if( irigel(6,i). eq .0) then
  201.             ifi=ifi-1
  202.             ipla=ifi
  203.           else
  204.            ide=ide+1
  205.             ipla=ide
  206.           endif
  207.           do ib=1,irigel(/1)
  208.             ri1.irigel(ib,ipla)=irigel(ib,i)
  209.           enddo
  210.           ri1.coerig(ipla)= coerig(i)
  211.         enddo
  212.         segdes ri1
  213. ****    segsup mrigid
  214.         mrigid=ri1
  215. *  une seule raideur en sortie
  216.         if (ri1.eq.0.or.iraid1.eq.0) then
  217.           mrigid = ri1+iraid1
  218.         else
  219.           call fusrig(ri1,iraid1,mrigid)
  220.         endif
  221. **    write(6,*) 'ri1 iraid1 mrigid en 217',ri1,iraid1,mrigid
  222.       else
  223.         mrigid = iraid1
  224.       endif
  225. *
  226.       if(mrigid.eq.0) then
  227.         call ecrent ( mrigid)
  228.       else
  229.         call  actobj('RIGIDITE',mrigid,0)
  230.         call  ecrobj('RIGIDITE',mrigid)
  231.       endif
  232.       if( mforc.eq.0) then
  233.          call ecrent (mforc)
  234.       else
  235. **       call ecchpo(mforc,1)
  236.          call actobj('CHPOINT', mforc,1)
  237.          call ecrobj('CHPOINT', mforc)
  238. **       write(6,*) ' mforc en sortie de rfco ',mforc
  239.       endif
  240. *     write(6,*) 'rfco mchelx ',mchelx
  241.       return
  242.  
  243.  9000 continue
  244.       call erreur (19)
  245.       end
  246.  
  247.  
  248.  
  249.  

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