Télécharger dbbsup.eso

Retour à la liste

Numérotation des lignes :

  1. C DBBSUP SOURCE PV 16/11/26 21:15:33 9205
  2. C suppression des doubles multiplicateurs de L sur une restitution
  3. C
  4. subroutine dbbsup(icolac)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. -INC TMCOLAC
  8. -INC SMELEME
  9. -INC SMRIGID
  10. -INC SMCHPOI
  11. -INC SMCOORD
  12. -INC CCOPTIO
  13. segment trav
  14. integer lag1(xcoor(/1)/(idim+1))
  15. integer lag2(xcoor(/1)/(idim+1))
  16. endsegment
  17.  
  18. write (6,*) ' fusion des doubles multiplicateurs de Lagrange'
  19. segact mcoord
  20. segini trav
  21. nbnn=2
  22. nbelem=0
  23. nbsous=0
  24. nbref=0
  25. segini ipt8
  26. ipt8.itypel=2
  27. segact icolac
  28. *
  29. * on construit d'abord le meleme des couples de multiplicateurs
  30. *
  31. ITLACC=KCOLA(1)
  32. segact itlacc
  33. IF (ITLAC(/1).EQ.0) GOTO 20
  34. DO 12 I=1,ITLAC(/1)
  35. MELEME=ITLAC(I)
  36. IF (meleme.eq.0) goto 12
  37. segact meleme*mod
  38. if (itypel.ne.22) then
  39. segdes meleme
  40. goto 12
  41. endif
  42. * ok on supprime le 2eme noeud
  43. nbele=num(/2)
  44. nbelem=nbelem+nbele
  45. nbnn=2
  46. segadj ipt8
  47. do 30 ie=1,nbele
  48. ipt8.num(1,nbelem-nbele+ie)=num(1,ie)
  49. ipt8.num(2,nbelem-nbele+ie)=num(2,ie)
  50. lag1(num(1,ie))=num(2,ie)
  51. lag2(num(2,ie))=num(1,ie)
  52. * do 40 in=2,num(/1)-1
  53. * num(in,ie)=num(in+1,ie)
  54. * 40 continue
  55. 30 continue
  56. * nbelem=num(/2)
  57. * nbnn=num(/1)-1
  58. * segadj meleme
  59. segdes meleme
  60. 12 continue
  61. 20 continue
  62. * on elimine dans les chpoint
  63. itlacc=kcola(2)
  64. segact itlacc
  65. if (itlac(/1).eq.0) goto 90
  66. do 100 i=1,itlac(/1)
  67. mchpoi=itlac(i)
  68. segact mchpoi
  69. do 110 isoupo=1,ipchp(/1)
  70. msoupo=ipchp(isoupo)
  71. segact msoupo
  72. if (nocomp(/2).ne.1) goto 110
  73. mul=0
  74. if (nocomp(1).eq.'LX') mul=2
  75. if (nocomp(1).eq.'FLX') mul=1
  76. if (mul.eq.0) goto 110
  77. write (6,*) ' conversion du mpoval ',ipoval,nocomp(1)
  78. meleme=igeoc
  79. segact meleme
  80. mpoval=ipoval
  81. segact mpoval*mod
  82. ict=0
  83. do 130 iv=1,vpocha(/1)
  84. if (lag2(num(1,iv)).ne.0) goto 130
  85. val=vpocha(iv,1)
  86. if (lag1(num(1,iv)).ne.0) val=mul*val
  87. ict=ict+1
  88. vpocha(iv,1)=val
  89. 130 continue
  90. n=ict
  91. nc=1
  92. segadj mpoval
  93. segdes mpoval,meleme
  94. 110 continue
  95. 100 continue
  96. 90 continue
  97. * on élimine dans les raideurs
  98. itlacc=kcola(3)
  99. segact itlacc
  100. if (itlac(/1).eq.0) goto 290
  101. do 300 i=1,itlac(/1)
  102. mrigid=itlac(i)
  103. segact mrigid
  104. do 310 ir=1,irigel(/2)
  105. descr=irigel(3,ir)
  106. segact descr*mod
  107. if (lisinc(2).ne.'LX') goto 311
  108. write (6,*) 'conversion de la raideur ',mrigid,ir
  109. do 320 il=2,lisinc(/2)-1
  110. lisinc(il)=lisinc(il+1)
  111. lisdua(il)=lisdua(il+1)
  112. noelep(il)=noelep(il+1)-1
  113. noeled(il)=noeled(il+1)-1
  114. 320 continue
  115. nligrp=lisinc(/2)-1
  116. nligrd=nligrp
  117. segadj descr
  118. xmatri=irigel(4,ir)
  119. segact xmatri*mod
  120. nelrig=re(/3)
  121. if (re(/1).ne.nligrd) then
  122. segadj xmatri
  123. do 330 im=1,nelrig
  124. * xmatri=imattt(im)
  125. * segact xmatri*mod
  126. * test si le xmatri a déjà été converti
  127. if (re(/1).eq.nligrd) goto 341
  128. do 340 il=1,nligrd
  129. do 340 ic=1,nligrd
  130. re(il,ic,im)=re(il+1,ic+1,im)
  131. 340 continue
  132. re(1,1,im)=0.d0
  133. * segadj xmatri
  134. 341 continue
  135. * segdes xmatri
  136. 330 continue
  137. endif
  138. segdes xmatri
  139. 311 continue
  140. segdes descr
  141. 310 continue
  142. segdes mrigid
  143. 300 continue
  144. 290 continue
  145. * on elimine dans les maillages en dernier
  146. itlacc=kcola(1)
  147. segact itlacc
  148. if (itlac(/1).eq.0) goto 190
  149. do 200 i=1,itlac(/1)
  150. meleme=itlac(i)
  151. segact meleme*mod
  152. if (itypel.ne.1 ) goto 210
  153. ict=0
  154. do 220 j=1,num(/2)
  155. if (lag2(num(1,j)).ne.0) goto 220
  156. ict=ict+1
  157. num(1,ict)=num(1,j)
  158. 220 continue
  159. if (nbelem.ne.ict)
  160. > write (6,*) ' conversion du meleme poin1 ',meleme
  161. nbnn=1
  162. nbelem=ict
  163. nbsous=0
  164. nbref=0
  165. segadj meleme
  166. 210 continue
  167. if (itypel.ne.22) goto 230
  168. write (6,*) ' conversion du meleme type 22 ',meleme
  169. do 240 j=1,num(/2)
  170. do 240 ip=num(/1)-1,2,-1
  171. num(ip,j)=num(ip+1,j)
  172. 240 continue
  173. nbnn=num(/1)-1
  174. nbelem=num(/2)
  175. nbsous=0
  176. nbref=0
  177. segadj meleme
  178. 230 continue
  179. segdes meleme
  180. 200 continue
  181. 190 continue
  182. segsup trav
  183. *
  184. return
  185. end
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  

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