Télécharger resouc.eso

Retour à la liste

Numérotation des lignes :

  1. C RESOUC SOURCE PV 19/11/15 21:16:07 10379
  2. subroutine resouc(mrigid,mrigic,idemem,ideme0,ideme1,
  3. > nounil,lagdua,icond,imult,if,imtvid,nelim)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. C
  7. C **** Eliminiation des relations dans une raideur
  8. C **** mrigic est la raideur resultante
  9. C icond dit si on a reussi a condense qque chose
  10. C imult dit si il reste des multiplicateurs non condensees
  11. C Ensuite reduction des seconds membres
  12. C
  13. -INC SMRIGID
  14. -INC CCOPTIO
  15. -INC SMCHPOI
  16. -INC SMELEME
  17. segment idemem(0)
  18. segment ideme0(idemem(/1),30)
  19. segment ideme1(idemem(/1),30)
  20. C on va separer les raideurs
  21. segact mrigid
  22. if (jrcond.eq.0) then
  23. call separm(mrigid,ri1,ri2,nounil,lagdua,nelim)
  24. if(ierr.ne.0) return
  25. segact ri1*mod
  26. segact ri2*mod
  27. * write(6,*) 'resouc ri1 ',ri1.mtymat
  28. * write(6,*) 'resouc ri2 ',ri2.mtymat
  29. if (ri1.ne.mrigid) ri1.mtymat='TEMPORAI'
  30. *xx ri2.mtymat='TEMPORAI'
  31. segact mrigid*mod
  32. jrelim=ri1
  33. jrgard=ri2
  34. imlag=max(0,lagdua)
  35. * write(6,*) ' if lagdua ',if,lagdua
  36. call fusrig(ri1,ri2,ipoir0)
  37. if(ierr.ne.0) return
  38. jrtot=ipoir0
  39. else
  40. ri1=jrelim
  41. ri2=jrgard
  42. ipoir0=jrtot
  43. lagdua=imlag
  44. ipt1=lagdua
  45. if (ipt1.ne.0) segact ipt1
  46. endif
  47. iri1s=ri1
  48. iri2s=ri2
  49. C
  50. 1010 continue
  51. C
  52. * mrigid matrice complete
  53. * ri1 dependance
  54. * ri2 les autres matrices
  55. * ri6 matrice de transfert
  56. * ri3 matrice reduite
  57. * ri5 matrice de transfert transposee
  58. C
  59. C on va proceder a la condensation rigidite puis forces
  60. if(jrcond.eq.0) then
  61.  
  62. CALL DEPEN3(RI1,RI6)
  63. if(ierr.ne.0) return
  64. * write(6,*) 'resouc ri6 ',ri6.mtymat
  65. segact ri6*mod
  66. if (ri6.ne.mrigid) ri6.mtymat='TEMPORAI'
  67. call scnd2 (ri2,ri6,ri3)
  68. if(ierr.ne.0) return
  69. segact ri3*mod
  70. * write(6,*) 'resouc ri3 ',ri3.mtymat
  71. if (ri3.ne.mrigid) ri3.mtymat='TEMPORAI'
  72. if(ierr.ne.0) then
  73. segsup ri1,ri2,ri6
  74. return
  75. endif
  76.  
  77. segact mrigid*mod
  78. jrcond=ri3
  79. JRDEPP=RI6
  80. C dualisation de la (les) matrice(s) de dependance
  81. call dual00(ri6,ri5)
  82. if(ierr.ne.0) return
  83. * write(6,*) 'resouc ri5 ',ri5.mtymat
  84. if (ri5.ne.mrigid) ri5.mtymat='TEMPORAI'
  85. jrdepd=ri5
  86. ipoiri = ri3
  87. else
  88. ipoiri= jrcond
  89. RI6 = JRDEPP
  90. ri5 = jrdepd
  91. endif
  92. * test si on a condense quelque chose
  93. segact ri1
  94. imult=ri1.irigel(/2)
  95. if (ri1.irigel(/2).gt.0) then
  96. imult=0
  97. do ir=1,ri1.irigel(/2)
  98. ipt1=ri1.irigel(1,ir)
  99. segact ipt1
  100. * if (ipt1.itypel.eq.22) then
  101. imult=imult+ipt1.num(/2)
  102. enddo
  103. endif
  104.  
  105.  
  106. * test si il reste des multiplicateurs dans ri3
  107. segact mrigid
  108. ri3=jrcond
  109. segact ri3*mod
  110. icond=0
  111. if (ri3.irigel(/2).eq.0) then
  112. imtvid=1
  113. * write(6,*) ' matrice vide ri3 '
  114. endif
  115. do ir=1,ri3.irigel(/2)
  116. ipt3=ri3.irigel(1,ir)
  117. segact ipt3
  118. if (ipt3.itypel.eq.22) icond=icond+ipt3.num(/2)
  119. enddo
  120. C
  121. *
  122. ri3.jrsup=mrigid
  123. mrigic = ri3
  124. * maintenant reduction des second membres
  125. * en cas de contacts on ne dualise pas . Ce sera fait dans unilater
  126. ifrot=0
  127. SEGACT MRIGID*MOD
  128. DO I=1,IRIGEL(/2)
  129. IF(IRIGEL(6,I).ne.0) ifrot=1
  130. enddo
  131. if (nounil.eq.1) ifrot=0
  132. if (lagdua.gt.0) then
  133. ipt8=lagdua
  134. if (ierr.ne.0) return
  135. segact ipt8
  136. endif
  137. do 1050 ig=1,idemem(/1)
  138. ichp2= idemem(ig)
  139. ideme0(ig,if)=ichp2
  140. * write(6,*) 'ideme0 ig if ',ideme0(ig,if),ig,if
  141. * transferer les valeurs imposees des relations sur les inconnues (à éliminer)
  142. call transr(ichp2,ri1,ichp3)
  143. if(ierr.ne.0) return
  144. ideme1(ig,if)=ichp3
  145. * write(6,*) 'ideme1 ig if ',ideme1(ig,if),ig,if
  146. call mucpri(ichp3,ri2,ichp4)
  147. * ri2 est deja dualise. Il faut donc dedualiser ichp4
  148. if (lagdua.gt.0) then
  149. call dbbcd(ichp4,lagdua)
  150. if(ierr.ne.0) return
  151. * write(6,*) ' appel dbbcf ',lagdua
  152. endif
  153. call adchpo(ichp2,ichp4,ichp1,1.D0,-1.0D0)
  154. if(ierr.ne.0) return
  155. call dtchpo(ichp4)
  156. call mucpri(ichp1,ri5,ichp2)
  157. if(ierr.ne.0) return
  158. mchpo1=ichp1
  159. mchpo2= ichp1
  160. segact mchpo2*mod
  161. mchpo2.jattri(1)=2
  162. mchpo2= ichp2
  163. segact mchpo2*mod
  164. mchpo2.jattri(1)=2
  165. segdes mchpo2
  166. C
  167. call fuchpo (ichp1,ichp2,ichp3)
  168. if(ierr.ne.0) return
  169. call dtchpo(ichp2)
  170. idemem(ig)=ichp3
  171. * vecteur a resoudre
  172. * dualisation des mult de lagrange
  173. if (lagdua.gt.0.and.ifrot.eq.0) then
  174. call dbbch(ichp3,lagdua)
  175. if(ierr.ne.0) return
  176. * write(6,*) ' appel dbbch ',lagdua
  177. endif
  178. 1050 continue
  179.  
  180. segdes ri1,ri2,ri3,ri5,ri6,mrigid
  181. return
  182. end
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  

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