Télécharger remplx.eso

Retour à la liste

Numérotation des lignes :

  1. C REMPLX SOURCE CB215821 19/05/21 21:15:18 10221
  2.  
  3. SUBROUTINE remplx(irig1,ipchp1,ipchp2 )
  4. c====================================================================
  5. c remplissage des LX apres reso avec condensation
  6. c entrees:
  7. c mrigid rigidité de dependance ( irigel(8,irig) # 0)
  8. C (elle contient les multiplicateurs)
  9. c ipchp1 chpoint de force cree par
  10. C (rigtot * soltot) - ftot
  11. c sorties:
  12. C ipchp2 chpoint des multiplicateurs a reintroduire
  13. C dans la solution globale
  14. C
  15. c====================================================================
  16. * on suppose pour le moment qu'il n'y a qu'une seule harmonique de fourier
  17.  
  18. IMPLICIT INTEGER(I-N)
  19. IMPLICIT REAL*8(A-H,O-Z)
  20. CHARACTER*4 CMOT
  21. -INC SMCHPOI
  22. -INC SMRIGID
  23. -INC SMELEME
  24. -INC SMCOORD
  25. -INC CCOPTIO
  26. -INC CCGEOME
  27. -INC CCHAMP
  28. character*4 NOMM,nom2
  29. C
  30. segment iccoun(ncomp)
  31. C
  32. segment iicpr
  33. integer icpr(nbpts),ivers(nbpts),iinb
  34. real*8 cvers(nbpts)
  35. endsegment
  36. segment siver2
  37. integer invnum(nbpts)
  38. integer iver2(nptc)
  39. real*8 cver2(nptc)
  40. endsegment
  41. SEGMENT SNOMIN
  42. CHARACTER*4 NOMIN(0)
  43. ENDSEGMENT
  44. SEGMENT SNOMDU
  45. CHARACTER*4 NODUA(0)
  46. ENDSEGMENT
  47. INTEGER IFO
  48. IFO = 0
  49. mrigid = irig1
  50. SEGACT mrigid
  51. nbpts = xcoor(/1)/(idim+1)
  52. segini snomin,snomdu
  53. C identification des inconnues liees
  54. DO 1501 I=1,IRIGEL(/2)
  55. MELEME=IRIGEL(1,I)
  56. C SEGACT MELEME
  57. DESCR=IRIGEL(3,I)
  58. ifo=irigel(5,i)
  59. SEGACT DESCR
  60. DO 1502 J=1,LISINC(/2)
  61. IF(LISINC(J).EQ.'LX '.AND.J.LE.1) GO TO 1502
  62. IF(NOMIN(/2).EQ.0) THEN
  63. NOMIN(**)=LISINC(J)
  64. NODUA(**)=LISDUA(J)
  65. ELSE
  66. DO 1506 K=1,NOMIN(/2)
  67. IF(LISINC(J).EQ.NOMIN(K)) GO TO 1505
  68. 1506 CONTINUE
  69. NOMIN(**)=LISINC(J)
  70. NODUA(**)=LISDUA(J)
  71. 1505 CONTINUE
  72. ENDIF
  73. 1502 CONTINUE
  74. SEGDES DESCR
  75. 1501 CONTINUE
  76. *C construction du tableau des duales
  77. * segini snomdu
  78. * do 325 il=1,nomin(/2)
  79. * NOMM =nomin(IL)
  80. * do 326 in = 1,lnomdd
  81. * if (NOMM.EQ.NOMDD(in)) then
  82. ** NODUA(il) =NOMDU(in)
  83. * goto 327
  84. * endif
  85. *326 continue
  86. *327 continue
  87. *325 continue
  88.  
  89. C WRITE(IOIMP,*) 'primales bloquees' ,(nomin(k),k=1,nomin(/2))
  90. C WRITE(IOIMP,*) 'leurs duales ' ,(nodua(k),k=1,nomin(/2))
  91.  
  92. ncomp = nomin(/2)
  93. segini iccoun
  94.  
  95. do 2000 ic = 1,ncomp
  96. segini iicpr
  97.  
  98. iccoun(ic) = iicpr
  99. C WRITE(IOIMP,*) ' composante et son iicpr ',ic,iicpr
  100. 2000 continue
  101.  
  102. ntplx = 0
  103. C quels sont les noeuds concernes par des liaisons
  104. do 1700 i=1,IRIGEL(/2)
  105. MELEME=IRIGEL(1,I)
  106. SEGACT MELEME
  107. ipt4=meleme
  108. descr = irigel(3,i)
  109. segact descr
  110. xmatri= irigel(4,i)
  111. segact xmatri
  112. if (lisinc(/2).le.1) goto 1701
  113. nomm = lisinc(2)
  114. C on l identifie par un numero ipo
  115. C pour recuperer les composantes ad hoc
  116.  
  117. C quelle est sa position dans nomin
  118.  
  119. do 3634 ipo=1,nomin(/2)
  120. if(NOMM.eq.nomin(ipo)) goto 3635
  121. 3634 continue
  122. 3635 continue
  123. C recup et comptage des noeuds supports de multiplicateurs
  124. ideb=2
  125. iicpr = iccoun(ipo)
  126. do 1703 iel=1,num(/2)
  127. * xmatri=imattt(iel)
  128. * segact xmatri
  129. ip =num(noelep(ideb),iel)
  130. * WRITE(IOIMP,*) ' remplissage ip icpr(ip) ',ip,num(1,iel)
  131. icpr(ip)=num(1,iel)
  132. iinb = iinb+1
  133. ivers(iinb)= ip
  134. cvers(iinb)= re(1,2,iel)*coerig(i)
  135. ntplx = ntplx+1
  136. * WRITE(IOIMP,*) 'ip icpr(ip) ipo' ,ip,icpr(ip),ipo
  137. * segdes xmatri
  138. 1703 continue
  139. 1701 continue
  140. segdes descr,xmatri
  141. 1700 continue
  142.  
  143. * WRITE(IOIMP,*) ' nombre de pts supports de LX ' ,ntplx
  144. C---------------------------------------------------------
  145. * WRITE(IOIMP,*) 'ivers ' ,(ivers(k),k=1,iinb)
  146. C on ouvre le chpoint des reactions calculees par KU-F
  147. mchpoi = ipchp1
  148. segact mchpoi
  149. nsoup1 = ipchp(/1)
  150.  
  151.  
  152. C initialisation du chpo de sortie support de ntplx points
  153. nat=1
  154. nsoupo = 1
  155. segini mchpo1
  156. ipchp2= mchpo1
  157. mchpo1.jattri(1) = 1
  158. mchpo1.ifopoi= ifopoi
  159. mchpo1.mochde='CHAMP DE LX ISSU DE REMPLX'
  160. mchpo1.mtypoi='REMPLX'
  161.  
  162. nc= 1
  163. segini msoup1
  164. mchpo1.ipchp(1)=msoup1
  165. C
  166. nbelem = ntplx
  167. nbnn = 1
  168. nbref = 0
  169. nbsous=0
  170. segini meleme
  171. msoup1.igeoc =meleme
  172. ipt1=meleme
  173. itypel= 1
  174.  
  175. n = ntplx
  176. msoup1.nocomp(1) = 'LX '
  177. msoup1.noharm(1)= ifo
  178. segini mpova1
  179. msoup1.ipoval = mpova1
  180.  
  181. inpp = 0
  182. do 1000 isous=1,nsoup1
  183. msoupo= ipchp(isous)
  184. segact msoupo
  185. meleme = igeoc
  186. segact meleme
  187. nc = nocomp(/2)
  188. mpoval=ipoval
  189. segact mpoval
  190. nptc = vpocha(/1)
  191. do 1010 icomp=1,nc
  192. nom2= nocomp(icomp)
  193. C recherche de l inconnue duale
  194. do 334 ipo=1,nomin(/2)
  195. * WRITE(IOIMP,*) ' nom de la composante et nodua ',nom2,NODUA(ipo)
  196. if(NOM2.eq.NODUA(ipo)) goto 335
  197. 334 continue
  198. C ce n est pas une composante depedante
  199. goto 1009
  200. 335 continue
  201. C WRITE(IOIMP,*) 'composante ->vpocha(1) ipo ' ,nom2 ,nptc,ipo
  202. iicpr = iccoun(ipo)
  203. C boucle sur les noeuds
  204. C WRITE(IOIMP,*) ' composante et son iicpr nbre ii ',ipo,iicpr,iinb
  205. segini siver2
  206. C WRITE(IOIMP,*) 'num(1,il)',(num(1,il),il=1,nptc)
  207.  
  208. C ****************************************************
  209. C [-DAVID-22/07/2004-] Inversion du tableau num suppression de la boucle 520
  210. * do 500 k=1,iinb
  211. * ip = ivers(k)
  212. * do 520 lk=1,nptc
  213. * if(ip.eq.num(1,lk)) then
  214. * iver2(lk)=ip
  215. * cver2(lk)=cvers(k)
  216. * goto 500
  217. * endif
  218. *520 continue
  219. *500 continue
  220. do lk = 1, nptc
  221. if ((num(1,lk).ge.1).and.(num(1,lk).le.nbpts)) then
  222. invnum(num(1,lk))=lk
  223. endif
  224. enddo
  225. do 500 k=1,iinb
  226. ip = ivers(k)
  227. lk = invnum(ip)
  228. if ((lk.ge.1).and.(lk.le.nptc)) then
  229. iver2(lk)=ip
  230. cver2(lk)=cvers(k)
  231. endif
  232. 500 continue
  233.  
  234. C WRITE(IOIMP,*) 'iver2 ' ,(iver2(k),k=1,nptc)
  235.  
  236. do 1020 j=1,nptc
  237. ip = iver2(j)
  238. if(ip.eq.0.or.icpr(ip).eq.0.or.iver2(j).eq.0) goto 1020
  239. * on ne dicise plus par deux puisque simple multiplicateur
  240. xfo=-vpocha(j,icomp)/1.D0/cver2(j)
  241. * WRITE(IOIMP,*) ' ip inpp icpr ',ip,inpp,icpr(ip)
  242. ipt1.num(1,inpp+1) = abs(icpr(ip))
  243. * pour avoir les LX au total
  244. icpr(ip)=-abs(icpr(ip))
  245. mpova1.vpocha(inpp+1,1)=xfo
  246. C WRITE(IOIMP,*) 'ip icpr xfo ',ip,icpr(ip),
  247. C & xfo,lk,(inpp+1)
  248. inpp = inpp+1
  249. 1020 continue
  250. segsup siver2
  251. 1009 continue
  252. 1010 continue
  253. segdes mpoval
  254. segdes msoupo
  255. 1000 continue
  256. * on complete les LX
  257. do 1022 ic=1,nomin(/2)
  258. iicpr = iccoun(ic)
  259. do 1021 j=1,icpr(/1)
  260. if (icpr(j).le.0) goto 1021
  261. * WRITE(IOIMP,*) ' complete j icpr(j) inpp num(/2) ',
  262. * > j,icpr(j),inpp,ipt1.num(/2)
  263. ipt1.num(1,inpp+1) = icpr(j)
  264. inpp=inpp+1
  265. 1021 continue
  266. 1022 continue
  267. * WRITE(IOIMP,*) ' on a ecrit ',inpp, ' LX'
  268. segdes mchpoi
  269. nbnn=ipt1.num(/1)
  270. nbelem=inpp
  271. nbsous=0
  272. nbref=0
  273. * WRITE(IOIMP,*) ' num mpova1 ',ipt1.num(/2),mpova1.vpocha(/1)
  274. if (nbelem.ne.ipt1.num(/2)) then
  275. * WRITE(IOIMP,*) ' remplx ajustement LX '
  276. segadj ipt1
  277. n=nbelem
  278. nc=1
  279. segadj mpova1
  280. endif
  281. segdes mpova1,msoup1,mchpo1
  282.  
  283. do 3000 ic=1,nomin(/2)
  284. iicpr = iccoun(ic)
  285. segsup iicpr
  286. 3000 continue
  287. segsup iccoun,snomin,snomdu
  288. segdes mrigid
  289. END
  290.  
  291.  

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