Télécharger resouc.eso

Retour à la liste

Numérotation des lignes :

resouc
  1. C RESOUC SOURCE MB234859 25/02/17 21:15:11 12155
  2. SUBROUTINE RESOUC(MRIGID,MRIGIC,IDEMEM,IDEME0,IDEME1,
  3. > NOUNIL,BDBLX,ICOND,IMULT,IF,IMTVID,NELIM)
  4. C----------------------------------------------------------------------
  5. C Subroutine dont le role est de :
  6. C - choisir les ddls a eliminer
  7. C - retirer les ddls elimines des autres rigidites et construire la
  8. C rigidite condensee
  9. C - modifier le second membre du fait de l'elimination de ddls
  10. C (ajout de forces et modification du jeu des relations ou un ddl
  11. C elimine intervient)
  12. C
  13. C Les multiplicateurs de Lagrange sont dedoubles.
  14. C
  15. C Entrees :
  16. C ---------
  17. C mrigid : pointeur sur la rigidite totale
  18. C idemem : tableau contenant le(s) second(s) membre(s)
  19. C nounil : vaut 0 si les conditions unilaterales doivent etre
  20. C traitees comme telles
  21. C nelim : vaut 0 s'il ne faut pas eliminer
  22. C if : passe d'elimination
  23. C bdblx : true si il faut dedoubler les mult. de Lagrange
  24. C
  25. C Sorties :
  26. C ---------
  27. C mrigic : pointeur sur la rigidite condensee
  28. C ideme0 : tableau contenant pour le(s) second(s) membre(s) les
  29. C valeurs des secondes membres a la passe d'elimination if
  30. C ideme1 : tableau contenant pour le(s) second(s) membre(s) les
  31. C valeurs de chaque condition eliminee a la passe d'elimination if
  32. C idemem : tableau contenant le(s) second(s) membre(s) apres la
  33. C passe d'elimiation if
  34. C imult : nombre de ddl(s) elimine(s)
  35. C icond : nombre de condition(s) restante(s)
  36. C imtvid : vaut 1 si la matrice condensee est vide
  37. C
  38. C----------------------------------------------------------------------
  39. IMPLICIT INTEGER(I-N)
  40. IMPLICIT REAL*8 (A-H,O-Z)
  41. C
  42. -INC PPARAM
  43. -INC CCOPTIO
  44. -INC SMRIGID
  45. -INC SMCHPOI
  46. -INC SMELEME
  47. C
  48. LOGICAL bdblx
  49. C
  50. segment idemem(0)
  51. segment ideme0(idemem(/1),30)
  52. segment ideme1(idemem(/1),30)
  53. C
  54. segact mrigid
  55. C write(6,*) ' resouc jrcond ichole ',jrcond,ichole,if
  56. C -----------------------------------------------------------------
  57. C Condensation des rigidites
  58. C -----------------------------------------------------------------
  59. if (jrcond.eq.0.and.ichole.eq.0) then
  60. C
  61. call separm(mrigid,ri1,ri2,nounil,bdblx,nelim,if)
  62. if(ierr.ne.0) return
  63. C
  64. call fusrig(ri1,ri2,ipoir0)
  65. if(ierr.ne.0) return
  66. C
  67. call depen3(ri1,ri6)
  68. if(ierr.ne.0) return
  69. C
  70. call scnd3(ri2,ri6,ri3)
  71. if(ierr.ne.0) return
  72. C
  73. call dual00(ri6,ri5)
  74. if(ierr.ne.0) return
  75. C
  76. segact mrigid*mod
  77. jrtot=ipoir0
  78. jrelim=ri1
  79. jrgard=ri2
  80. jrcond=ri3
  81. jrdepd=ri5
  82. jrdepp=ri6
  83. lagdua=0
  84. if (bdblx) then
  85. lagdua=ri2.imlag
  86. endif
  87. imlag=lagdua
  88. segact ri3*mod
  89. ri3.jrsup=mrigid
  90. ri3.imlag=imlag
  91. else
  92. ri1=jrelim
  93. ri2=jrgard
  94. ri3=jrcond
  95. ri5=jrdepd
  96. ri6=jrdepp
  97. lagdua=imlag
  98. endif
  99. mrigic=ri3
  100. segact,ri3
  101. C -----------------------------------------------------------------
  102. C Nombre de ddl elimine
  103. segact ri1
  104. imult=0
  105. if (ri1.irigel(/2).gt.0) then
  106. do ir=1,ri1.irigel(/2)
  107. ipt1=ri1.irigel(1,ir)
  108. segact ipt1
  109. imult=imult+ipt1.num(/2)
  110. enddo
  111. endif
  112. C
  113. C Nombre de conditions restantes dans ri3
  114. icond=0
  115. if (ri3.irigel(/2).eq.0) then
  116. imtvid=1
  117. * write(6,*) ' matrice vide ri3 '
  118. endif
  119. do ir=1,ri3.irigel(/2)
  120. ipt3=ri3.irigel(1,ir)
  121. segact ipt3
  122. if (ipt3.itypel.eq.22) icond=icond+ipt3.num(/2)
  123. enddo
  124. C -----------------------------------------------------------------
  125. C Condensation des second membres
  126. C -----------------------------------------------------------------
  127. do 1050 ig=1,idemem(/1)
  128. ichp2= idemem(ig)
  129. ideme0(ig,if)=ichp2
  130. * write(6,*) 'ideme0 ig if ',ideme0(ig,if),ig,if
  131. C Transferer les valeurs imposees des relations sur les inconnues à éliminer
  132. call transr(ichp2,ri1,ichp3)
  133. if(ierr.ne.0) return
  134. ideme1(ig,if)=ichp3
  135. * write(6,*) 'ideme1 ig if ',ideme1(ig,if),ig,if
  136. call mucpri(ichp3,ri2,ichp4)
  137. if(ierr.ne.0) return
  138. * Si lagdua /= 0, ri2 est deja dualise et il faut dedualiser ichp4
  139. call dbbcd(ichp4,lagdua)
  140. if(ierr.ne.0) return
  141. call adchpo(ichp2,ichp4,ichp1,1.D0,-1.0D0)
  142. if(ierr.ne.0) return
  143. call dtchpo(ichp4)
  144. call mucpri(ichp1,ri5,ichp2)
  145. if(ierr.ne.0) return
  146. C ichp1 et ichp2 sont censes etre de nature DISCRETE (JATTRI(1)=2)
  147. call adchpo(ichp1,ichp2,ichp3,1.D0,1.D0)
  148. if(ierr.ne.0) return
  149. if (ichp2.ne.ichp3) call dtchpo(ichp2)
  150. C Dedoublement des mult de lagrange
  151. call dbbch(ichp3,lagdua)
  152. * write(6,*) ' appel dbbch ',lagdua
  153. if(ierr.ne.0) return
  154. idemem(ig)=ichp3
  155. 1050 CONTINUE
  156. C -----------------------------------------------------------------
  157. segdes ri1,ri2,ri3,ri5,ri6,mrigid
  158. RETURN
  159. END
  160.  
  161.  
  162.  

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