Télécharger resouc.eso

Retour à la liste

Numérotation des lignes :

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

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