Télécharger remplx.eso

Retour à la liste

Numérotation des lignes :

  1. C REMPLX SOURCE GF238795 18/02/05 21:15:53 9726
  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 meleme,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,meleme
  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 ipt1,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. RETURN
  290. END
  291.  
  292.  
  293.  
  294.  
  295.  
  296.  
  297.  
  298.  
  299.  
  300.  
  301.  
  302.  
  303.  
  304.  
  305.  
  306.  
  307.  
  308.  
  309.  
  310.  
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  
  324.  
  325.  
  326.  
  327.  

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