Télécharger kres6.eso

Retour à la liste

Numérotation des lignes :

  1. C KRES6 SOURCE GOUNAND 19/07/03 21:15:06 10248
  2. SUBROUTINE KRES6(MRIGID,KSMBR,LDMULT,NELIM,
  3. $ MRIGIC,KSMBRC,KSMBR1)
  4. * SUBROUTINE KRES6(MRIGID,KSMBR,IDEPE,
  5. * $ MRIGIC,KSMBRC,KSMBR0,KSMBR1)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. IMPLICIT INTEGER (I-N)
  8. C***********************************************************************
  9. C NOM : KRES6
  10. C DESCRIPTION : Effectue la condensation des relations
  11. C Repris de resou.eso
  12. C
  13. C
  14. C LANGAGE : ESOPE
  15. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  16. C mél : gounand@semt2.smts.cea.fr
  17. C***********************************************************************
  18. C VERSION : v1, 15/06/2011, version initiale
  19. C HISTORIQUE : v1, 15/06/2011, création
  20. C HISTORIQUE : 2019/04/10 remplacement de NOEL par NELIM
  21. C Idéalement, il faudrait reprendre ce que Pierre a fait dans
  22. C RESOU dans les fiches 10[0,1]?? et avec MREM.
  23. C HISTORIQUE :
  24. C***********************************************************************
  25. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  26. C en cas de modification de ce sous-programme afin de faciliter
  27. C la maintenance !
  28. C***********************************************************************
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC SMRIGID
  33. -INC SMCHPOI
  34. -INC SMELEME
  35. *
  36. * Logique indiquant si on dualise les multiplicateurs de Lagrange
  37. LOGICAL LDMULT
  38. *
  39. NOUNIL=0
  40. NOEN=1
  41. IPOIRI=MRIGID
  42. * verification pas de blocage en double
  43. call verlag(ipoiri)
  44. if (ierr.ne.0) return
  45. * y a t il des matrices de relations non unilaterales
  46. ipoir0 = ipoiri
  47. mrigid=ipoiri
  48. C call prrigi(ipoiri,1)
  49. segact mrigid
  50. nrige= irigel(/1)
  51. idepe=0
  52. nbr = irigel(/2)
  53. do 1000 irig = 1,nbr
  54. meleme=irigel(1,irig)
  55. segact meleme
  56. if ((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22)
  57. > idepe=idepe+1
  58. if (irigel(6,irig).ne.0) iunil=1
  59. segdes meleme
  60. 1000 continue
  61. * idepe=0
  62. lagdua=0
  63. if(idepe.ne.0) then
  64. C on va separer les raideurs
  65. * write (6,*) ' nounil jrcond iunil idepe vaut ',nounil,jrcond,
  66. * $ iunil, idepe
  67. if (jrcond.eq.0) then
  68. *transmis en argument nelim=1
  69. if (ldmult) then
  70. call separm(mrigid,ri1,ri2,nounil,lagdua,nelim)
  71. else
  72. call separm(mrigid,ri1,ri2,nounil,-1,nelim)
  73. endif
  74. * if (lagdua.ne.0) then
  75. * write(6,*) ' resou apres separm -- lagdua'
  76. * call ecmail(lagdua)
  77. * else
  78. * write(6,*) ' resou apres separm -- lagdua=0'
  79. * endif
  80. * write(6,*) ' resou apres separm -- ri2'
  81. * call prrigi(ri2,1)
  82. * write(6,*) ' resou apres separm -- ri1'
  83. * call prrigi ( ri1,0)
  84. * write(6,*) ' fin impression ri1'
  85. segact mrigid*mod
  86. jrelim=ri1
  87. jrgard=ri2
  88. imlag=lagdua
  89. call fusrig(ri1,ri2,ipoir0)
  90. jrtot=ipoir0
  91. else
  92. ri1=jrelim
  93. ri2=jrgard
  94. ipoir0=jrtot
  95. lagdua=imlag
  96. ipt1=lagdua
  97. if (ipt1.ne.0) segact ipt1
  98. endif
  99. C
  100. * mrigid matrice complete
  101. * ri1 dependance
  102. * ri2 les autres matrices
  103. * ri6 matrice de transfert
  104. * ri3 matrice reduite
  105. * ri5 matrice de transfert transposee
  106. C
  107. C on va proceder a la condensation rigidite puis forces
  108. if(jrcond.eq.0) then
  109. CALL DEPEN3(RI1,RI6)
  110. * write (6,*) ' resou apres depen3 --- ri6 '
  111. * call prrigi(ri6,1)
  112. call scnd2 (ri2,ri6,ri3)
  113. * write (6,*) ' '
  114. * write (6,*) ' '
  115. * write (6,*) ' resou apres scnd2--- ri3 '
  116. * write (6,*) ' '
  117. * call prrigi(ri3,1)
  118. segact ri3
  119. if(ierr.ne.0) then
  120. segsup ri1,ri2,ri6
  121. return
  122. endif
  123.  
  124. segact mrigid*mod
  125. jrcond=ri3
  126. JRDEPP=RI6
  127. C dualisation de la (les) matrice(s) de dependance
  128. call dual00(ri6,ri5)
  129. * write(6,*) ' apres dual0 -- ri5'
  130. * call prrigi( ri5,1)
  131. jrdepd=ri5
  132. ipoiri = ri3
  133. else
  134. ipoiri= jrcond
  135. RI6 = JRDEPP
  136. ri5 = jrdepd
  137. endif
  138. * test si ri3 est vide
  139. ri3=jrcond
  140. segact ri3
  141. * write (6,*) ' dans resou ri3.irigel(/2) ',ri3.irigel(/2)
  142. if (ri3.irigel(/2).eq.0) imtvid=1
  143. C
  144. segdes ri1,ri2,mrigid
  145. mrigic=ipoiri
  146. C maintenant les seconds membres
  147. C write(6,*) ' ipoiri jrdepp jrdepd',ipoiri,ri6,ri5
  148. C call prrigi(ri3)
  149. C call prrigi(ri5)
  150. * en cas de contacts on ne dualise pas . Ce sera fait dans unilater
  151. ifrot=0
  152. MRIGID=IPOIRI
  153. SEGACT MRIGID*MOD
  154. DO I=1,IRIGEL(/2)
  155. IF(IRIGEL(6,I).ne.0) ifrot=1
  156. enddo
  157. if (nounil.eq.1) ifrot=0
  158. * if (ifrot.eq.0) write (6,*) ' resou non unilateral '
  159. * if (ifrot.eq.1) write (6,*) ' resou unilateral pas de dualisation'
  160. if (lagdua.ne.0) then
  161. ipt8=lagdua
  162. segact ipt8
  163. * call ecmail(lagdua,0)
  164. endif
  165. *
  166. ichp2=ksmbr
  167. * ksmbr0=ichp2
  168. * transferer les valeurs imposees des relations sur les inconnues (à éliminer
  169. C )
  170. * write (6,*) ' valeurs imposees ichp2'
  171. * call ecchpo(ichp2,0)
  172. call transr(ichp2,ri1,ichp3)
  173. * call prrigi(ri1)
  174. * write (6,*) ' apres transfert ichp3'
  175. * call ecchpo(ichp3,0)
  176. ksmbr1=ichp3
  177. call mucpri(ichp3,ri2,ichp4)
  178. * write (6,*) ' apres mucpri ichp4 '
  179. * call ecchpo(ichp4,0)
  180. * ri2 est deja dualise. Il faut donc dedualiser ichp4
  181. call dbbcd(ichp4,lagdua)
  182. * write (6,*) ' apres dbbcd ichp4 '
  183. * call ecchpo(ichp4,0)
  184. call adchpo(ichp2,ichp4,ichp1,1.D0,-1.0D0)
  185. call dtchpo(ichp4)
  186. * write (6,*) ' apres adchpo ichp1'
  187. * call ecchpo(ichp1,0)
  188. call mucpri(ichp1,ri5,ichp2)
  189. * write (6,*) ' impression de ri5 '
  190. * call prrigi(ri5,1)
  191. * write (6,*) ' apres mucpri ichp2'
  192. * call ecchpo(ichp2,0)
  193. C mchpo1=ichp1
  194. C segact mchpo1
  195. C write(6,*) 'reso mchpo1 jattri(1)',mchpo1.jattri(1)
  196. C segdes mchpo1
  197. C
  198. mchpo2= ichp1
  199. segact mchpo2*mod
  200. mchpo2.jattri(1)=2
  201. mchpo2= ichp2
  202. segact mchpo2*mod
  203. mchpo2.jattri(1)=2
  204. C write(6,*) 'reso mchpo2 jattri(1)',mchpo2.jattri(1)
  205. segdes mchpo2
  206. C
  207. call fuchpo (ichp1,ichp2,ichp3)
  208. * call dtchpo(ichp1)
  209. call dtchpo(ichp2)
  210. * Ajout gounand : à ce stade, la force réduite n'est pas nulle sur les
  211. * ddls supprimés (multiplicateurs de Lagrange et ddl dépendants), on les
  212. * enlève.
  213. * vecteur a resoudre
  214. * write (6,*) ' le vecteur avant reduction '
  215. * call ecchpo(ichp3,0)
  216. ichp2=ichp3
  217. CALL redfor(ichp2,ri1,ichp3)
  218. if (ierr.ne.0) return
  219. call dtchpo(ichp2)
  220. ksmbrc=ichp3
  221. * vecteur a resoudre
  222. * write (6,*) ' le vecteur '
  223. * call ecchpo(ichp3,0)
  224. * dualisation des mult de lagrange
  225. if (lagdua.ne.0.and.ifrot.eq.0) call dbbch(ichp3,lagdua)
  226. * matrice
  227. * write (6,*) ' la matrice '
  228. * call prrigi(ipoiri)
  229. noid = 1
  230. else
  231. mrigic=mrigid
  232. ksmbrc=ksmbr
  233. ksmbr1=0
  234. endif
  235.  
  236.  
  237.  
  238. RETURN
  239. *
  240. * End of subroutine KRES6
  241. *
  242. END
  243.  
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  
  250.  
  251.  

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