Télécharger remplx.eso

Retour à la liste

Numérotation des lignes :

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

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