Télécharger kres6.eso

Retour à la liste

Numérotation des lignes :

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

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