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. -INC CCOPTIO
  30. -INC SMRIGID
  31. -INC SMCHPOI
  32. -INC SMELEME
  33. *
  34. * Logique indiquant si on dualise les multiplicateurs de Lagrange
  35. LOGICAL LDMULT
  36. *
  37. NOUNIL=0
  38. NOEN=1
  39. IPOIRI=MRIGID
  40. * verification pas de blocage en double
  41. call verlag(ipoiri)
  42. if (ierr.ne.0) return
  43. * y a t il des matrices de relations non unilaterales
  44. ipoir0 = ipoiri
  45. mrigid=ipoiri
  46. C call prrigi(ipoiri,1)
  47. segact mrigid
  48. nrige= irigel(/1)
  49. idepe=0
  50. nbr = irigel(/2)
  51. do 1000 irig = 1,nbr
  52. meleme=irigel(1,irig)
  53. segact meleme
  54. if ((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22)
  55. > idepe=idepe+1
  56. if (irigel(6,irig).ne.0) iunil=1
  57. segdes meleme
  58. 1000 continue
  59. * idepe=0
  60. lagdua=0
  61. if(idepe.ne.0) then
  62. C on va separer les raideurs
  63. * write (6,*) ' nounil jrcond iunil idepe vaut ',nounil,jrcond,
  64. * $ iunil, idepe
  65. if (jrcond.eq.0) then
  66. *transmis en argument nelim=1
  67. if (ldmult) then
  68. call separm(mrigid,ri1,ri2,nounil,lagdua,nelim)
  69. else
  70. call separm(mrigid,ri1,ri2,nounil,-1,nelim)
  71. endif
  72. * if (lagdua.ne.0) then
  73. * write(6,*) ' resou apres separm -- lagdua'
  74. * call ecmail(lagdua)
  75. * else
  76. * write(6,*) ' resou apres separm -- lagdua=0'
  77. * endif
  78. * write(6,*) ' resou apres separm -- ri2'
  79. * call prrigi(ri2,1)
  80. * write(6,*) ' resou apres separm -- ri1'
  81. * call prrigi ( ri1,0)
  82. * write(6,*) ' fin impression ri1'
  83. segact mrigid*mod
  84. jrelim=ri1
  85. jrgard=ri2
  86. imlag=lagdua
  87. call fusrig(ri1,ri2,ipoir0)
  88. jrtot=ipoir0
  89. else
  90. ri1=jrelim
  91. ri2=jrgard
  92. ipoir0=jrtot
  93. lagdua=imlag
  94. ipt1=lagdua
  95. if (ipt1.ne.0) segact ipt1
  96. endif
  97. C
  98. * mrigid matrice complete
  99. * ri1 dependance
  100. * ri2 les autres matrices
  101. * ri6 matrice de transfert
  102. * ri3 matrice reduite
  103. * ri5 matrice de transfert transposee
  104. C
  105. C on va proceder a la condensation rigidite puis forces
  106. if(jrcond.eq.0) then
  107. CALL DEPEN3(RI1,RI6)
  108. * write (6,*) ' resou apres depen3 --- ri6 '
  109. * call prrigi(ri6,1)
  110. call scnd2 (ri2,ri6,ri3)
  111. * write (6,*) ' '
  112. * write (6,*) ' '
  113. * write (6,*) ' resou apres scnd2--- ri3 '
  114. * write (6,*) ' '
  115. * call prrigi(ri3,1)
  116. segact ri3
  117. if(ierr.ne.0) then
  118. segsup ri1,ri2,ri6
  119. return
  120. endif
  121.  
  122. segact mrigid*mod
  123. jrcond=ri3
  124. JRDEPP=RI6
  125. C dualisation de la (les) matrice(s) de dependance
  126. call dual00(ri6,ri5)
  127. * write(6,*) ' apres dual0 -- ri5'
  128. * call prrigi( ri5,1)
  129. jrdepd=ri5
  130. ipoiri = ri3
  131. else
  132. ipoiri= jrcond
  133. RI6 = JRDEPP
  134. ri5 = jrdepd
  135. endif
  136. * test si ri3 est vide
  137. ri3=jrcond
  138. segact ri3
  139. * write (6,*) ' dans resou ri3.irigel(/2) ',ri3.irigel(/2)
  140. if (ri3.irigel(/2).eq.0) imtvid=1
  141. C
  142. segdes ri1,ri2,mrigid
  143. mrigic=ipoiri
  144. C maintenant les seconds membres
  145. C write(6,*) ' ipoiri jrdepp jrdepd',ipoiri,ri6,ri5
  146. C call prrigi(ri3)
  147. C call prrigi(ri5)
  148. * en cas de contacts on ne dualise pas . Ce sera fait dans unilater
  149. ifrot=0
  150. MRIGID=IPOIRI
  151. SEGACT MRIGID*MOD
  152. DO I=1,IRIGEL(/2)
  153. IF(IRIGEL(6,I).ne.0) ifrot=1
  154. enddo
  155. if (nounil.eq.1) ifrot=0
  156. * if (ifrot.eq.0) write (6,*) ' resou non unilateral '
  157. * if (ifrot.eq.1) write (6,*) ' resou unilateral pas de dualisation'
  158. if (lagdua.ne.0) then
  159. ipt8=lagdua
  160. segact ipt8
  161. * call ecmail(lagdua,0)
  162. endif
  163. *
  164. ichp2=ksmbr
  165. * ksmbr0=ichp2
  166. * transferer les valeurs imposees des relations sur les inconnues (à éliminer
  167. C )
  168. * write (6,*) ' valeurs imposees ichp2'
  169. * call ecchpo(ichp2,0)
  170. call transr(ichp2,ri1,ichp3)
  171. * call prrigi(ri1)
  172. * write (6,*) ' apres transfert ichp3'
  173. * call ecchpo(ichp3,0)
  174. ksmbr1=ichp3
  175. call mucpri(ichp3,ri2,ichp4)
  176. * write (6,*) ' apres mucpri ichp4 '
  177. * call ecchpo(ichp4,0)
  178. * ri2 est deja dualise. Il faut donc dedualiser ichp4
  179. call dbbcd(ichp4,lagdua)
  180. * write (6,*) ' apres dbbcd ichp4 '
  181. * call ecchpo(ichp4,0)
  182. call adchpo(ichp2,ichp4,ichp1,1.D0,-1.0D0)
  183. call dtchpo(ichp4)
  184. * write (6,*) ' apres adchpo ichp1'
  185. * call ecchpo(ichp1,0)
  186. call mucpri(ichp1,ri5,ichp2)
  187. * write (6,*) ' impression de ri5 '
  188. * call prrigi(ri5,1)
  189. * write (6,*) ' apres mucpri ichp2'
  190. * call ecchpo(ichp2,0)
  191. C mchpo1=ichp1
  192. C segact mchpo1
  193. C write(6,*) 'reso mchpo1 jattri(1)',mchpo1.jattri(1)
  194. C segdes mchpo1
  195. C
  196. mchpo2= ichp1
  197. segact mchpo2*mod
  198. mchpo2.jattri(1)=2
  199. mchpo2= ichp2
  200. segact mchpo2*mod
  201. mchpo2.jattri(1)=2
  202. C write(6,*) 'reso mchpo2 jattri(1)',mchpo2.jattri(1)
  203. segdes mchpo2
  204. C
  205. call fuchpo (ichp1,ichp2,ichp3)
  206. * call dtchpo(ichp1)
  207. call dtchpo(ichp2)
  208. * Ajout gounand : à ce stade, la force réduite n'est pas nulle sur les
  209. * ddls supprimés (multiplicateurs de Lagrange et ddl dépendants), on les
  210. * enlève.
  211. * vecteur a resoudre
  212. * write (6,*) ' le vecteur avant reduction '
  213. * call ecchpo(ichp3,0)
  214. ichp2=ichp3
  215. CALL redfor(ichp2,ri1,ichp3)
  216. if (ierr.ne.0) return
  217. call dtchpo(ichp2)
  218. ksmbrc=ichp3
  219. * vecteur a resoudre
  220. * write (6,*) ' le vecteur '
  221. * call ecchpo(ichp3,0)
  222. * dualisation des mult de lagrange
  223. if (lagdua.ne.0.and.ifrot.eq.0) call dbbch(ichp3,lagdua)
  224. * matrice
  225. * write (6,*) ' la matrice '
  226. * call prrigi(ipoiri)
  227. noid = 1
  228. else
  229. mrigic=mrigid
  230. ksmbrc=ksmbr
  231. ksmbr1=0
  232. endif
  233.  
  234.  
  235.  
  236. RETURN
  237. *
  238. * End of subroutine KRES6
  239. *
  240. END
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  

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