Esope source files

   1 : C FRIG      SOURCE    FANDEUR   11/10/07    21:15:27     7159           
   2 : 
   3 :       SUBROUTINE FRIG
   4 : 
   5 :       IMPLICIT INTEGER(I-N)
   6 :       IMPLICIT REAL*8(A-H,O-Z)
   7 : 
   8 : *  Ce sous-programme calcule la raideur de frottement.
   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 CCOPTIO
  13 : -INC CCREEL
  14 : 
  15 : -INC SMCHPOI
  16 : -INC SMCOORD
  17 : -INC SMELEME
  18 : -INC SMMODEL
  19 : -INC SMRIGID
  20 : 
  21 :       logical ltelq
  22 : 
  23 :       idimp1 = IDIM + 1
  24 : *
  25 : * Test sur les options de calcul
  26 :       if (idim .ne. 3) then
  27 :         if (ifomod .ne. -1 .and. ifomod .ne. 0) then
  27 :           call erreur(710)
  28 :           return
  29 :         endif
  30 :       endif
  31 : *
  32 : * Lecture obligatoire du modele de frottement
  33 : *
  33 :       call LIROBJ('MMODEL' , modini,1,iretou)
  34 :       if (ierr.ne.0) return
  35 : *
  36 : * Quelques initialisations
  37 : *
  38 :       mmodel = modini
  39 :       segact mmodel
  40 :       nsous = kmodel(/1)
  41 :       n1 = nsous
  42 :       segini,mmode1
  43 :       segini,mmode2
  44 : *
  45 : * Travail préparatoire de separation des modeles de frottement
  46 : *
  47 :       icoulo = 0
  48 :       icable = 0
  49 :       ipp2 = 0
  50 :       ltelq=.false.
  51 :       do 700 imod = 1, nsous
  52 :         imodel= kmodel(imod)
  53 :         segact imodel
  54 :         if (matmod(1).eq.'COULOMB') then
  55 :           icoulo=icoulo+1
  56 :           mmode1.kmodel(icoulo) = imodel
  57 : *  modele(s) de Coulomb : on agglomere les maillages sous-jacents
  58 :           if (icoulo.eq.1) then
  59 :             ipp2 = imamod
  60 :           else
  61 :             meleme = ipp2
  62 :             ipp1 = imamod
  62 :             call fuse(meleme,ipp1,ipp2,ltelq)
  63 :             if (icoulo.ge.3) segsup,meleme
  64 :           endif
  65 :         else if (matmod(1).eq.'FROCABLE') then
  66 :           icable = icable+1
  67 :           mmode2.kmodel(icable) = imodel
  68 :         else
  69 :           segdes,imodel
  70 :         endif
  71 :  700  continue
  72 :       segdes mmodel
  73 :       n1 = icoulo
  74 :       segadj,mmode1
  75 :       modcou = mmode1
  76 :       n1 = icable
  77 :       segadj,mmode2
  78 :       modcab = mmode2
  79 :       if (icoulo.eq.0 .and. icable.eq.0) then
  79 :         call erreur(21)
  80 :         goto 9000
  81 :       endif
  82 : *
  83 : * Lecture conditionnelle des arguments (selon les modeles de frottement)
  84 : *
  85 :       lecond = 0
  86 :       if (icoulo.ne.0) lecond = 1
  87 : *
  88 :       iraidc = 0
  89 :       ichjeu = 0
  90 : *
  91 : * Lecture de la raideur de contact
  91 :       call lirobj('RIGIDITE',iraidc,lecond,iretou)
  92 :       if (ierr.ne.0) GOTO 9000
  93 : *
  94 : * Lecture du champ de jeux
  94 :       call lirobj('CHPOINT ',ichjeu,lecond,iretou)
  95 :       if (ierr.ne.0) GOTO 9000
  96 : *
  97 : * Initialisation de la raideur (totale) de frottement
  98 : *
  99 :       mrigid = 0
 100 : *
 101 : * Traitement des modeles de Coulomb
 102 : *
 103 :       if (icoulo.ne.0) then
 104 :         ri1 = 0
 105 :         meleme = ipp2
 106 :         if (idim .eq. 3) then
 106 :           call frig3C(meleme,iraidc,ichjeu, ri1)
 107 :         else
 107 :           call frig2C(meleme,iraidc,ichjeu, ri1)
 108 :         endif
 109 :         if (icoulo.ge.2) segsup meleme
 110 :         if (ierr.ne.0 .or. ri1.eq.0) goto 9000
 111 :         mrigid = ri1
 112 :       endif
 113 : *
 114 : * Traitement des modeles Frocable
 115 : *
 116 :       if (icable.ne.0) then
 117 :         mmodel = modcab
 118 : * Petit modele unitaire local (a detruire en fin de traitement)
 119 :         n1=1
 120 :         segini,mmode2
 121 : * Option accro 'GLISS'
 122 :         igliss=1
 123 :         DO 500 imod=1,icable
 124 :           imodel = kmodel(imod)
 125 : C*        segact imodel
 126 :           segact,mmode2*mod
 127 :           mmode2.kmodel(1)=imodel
 128 :           do io=1,ivamod(/1)
 129 :             if (tymode(io).eq.'MAILLAGE') go to 510
 130 :           enddo
 130 :           call erreur(16)
 131 :           goto 9000
 132 :  510      continue
 133 :           ri2 = 0
 134 :           meleme=ivamod(io)
 134 :           call ecrobj('MAILLAGE',meleme)
 134 :           call ecrobj('MMODEL  ',mmode2)
 134 :           call accro(igliss)
 135 :           if (ierr.ne.0) goto 9000
 135 :           call lirobj('RIGIDITE',ri2,1,iretou)
 136 :           if (ierr.ne.0) goto 9000
 137 : c*        segdes imodel (desactive par accro)
 138 : c* On fusionne ri2 dans la rigidite (totale) mrigid
 139 :           if (mrigid.eq.0) then
 140 :             mrigid = ri2
 141 :           else
 142 :             segact,mrigid*mod,ri2
 143 :             nriav  = irigel(/2)
 144 :             nrigel = nriav + ri2.irigel(/2)
 145 :             segadj,mrigid
 146 :             do io = 1, ri2.irigel(/2)
 147 :               do iu = 1, ri2.irigel(/1)
 148 :                 irigel(iu,io+nriav) = ri2.irigel(iu,io)
 149 :               enddo
 150 :               coerig(io+nriav) = ri2.coerig(io)
 151 :             enddo
 152 :             segsup ri2
 153 :           endif
 154 :  500    continue
 155 :         segdes mrigid
 156 :         segsup mmode2
 157 :       endif
 158 : *
 159 : *  traitement des modeles ...
 160 : *
 161 : * ->  Brancher ici le traitement specifique a chaque autre modele de
 162 : *     frottement qui doit fournir la rigidite de frottement associee
 163 : *     qui sera fusionnee dans la rigidite mrigid (cf. modeles frocable)
 164 : *
 165 : *  Fin du traitement :
 166 : *
 166 :       call ecrobj('RIGIDITE',mrigid)
 166 : *      call prrigi(mrigid)
 167 : 
 168 :  9000 CONTINUE
 169 :       mmode1 = modcou
 170 :       segsup,mmode1
 171 :       mmode1 = modcab
 172 :       segsup,mmode1
 173 : *
 174 :       return
 175 :       end
 176 : 
 177 :