Télécharger remplx.eso

Retour à la liste

Numérotation des lignes :

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

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