C REMPLX SOURCE PV090527 26/04/30 21:16:12 12529 SUBROUTINE remplx(irig1,ipchp1,ipchp2 ) c==================================================================== c remplissage des LX apres reso avec condensation c entrees: c mrigid rigidité de dependance ( irigel(8,irig) # 0) C (elle contient les multiplicateurs) c ipchp1 chpoint de force cree par C (rigtot * soltot) - ftot c sorties: C ipchp2 chpoint des multiplicateurs a reintroduire C dans la solution globale C c==================================================================== * on suppose pour le moment qu'il n'y a qu'une seule harmonique de fourier IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC SMCHPOI -INC SMRIGID -INC SMELEME -INC SMCOORD -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC CCHAMP character*(LOCOMP) NOMM,nom2 C segment iccoun(ncomp) C segment iicpr integer icpr(nbpts),ivers(nbpts),iinb real*8 cvers(nbpts) endsegment segment siver2 integer invnum(nbpts) integer iver2(nptc) real*8 cver2(nptc) endsegment SEGMENT SNOMIN CHARACTER*(LOCOMP) NOMIN(0) ENDSEGMENT SEGMENT SNOMDU CHARACTER*(LOCOMP) NODUA(0) ENDSEGMENT INTEGER IFO IFO = 0 mrigid = irig1 SEGACT mrigid segini snomin,snomdu C identification des inconnues liees DO 1501 I=1,IRIGEL(/2) MELEME=IRIGEL(1,I) C SEGACT MELEME DESCR=IRIGEL(3,I) ifo=irigel(5,i) SEGACT DESCR DO 1502 J=1,LISINC(/2) IF(LISINC(J).EQ.'LX '.AND.J.LE.1) GO TO 1502 IF(NOMIN(/2).EQ.0) THEN NOMIN(**)=LISINC(J) NODUA(**)=LISDUA(J) ELSE DO 1506 K=1,NOMIN(/2) IF(LISINC(J).EQ.NOMIN(K)) GO TO 1505 1506 CONTINUE NOMIN(**)=LISINC(J) NODUA(**)=LISDUA(J) 1505 CONTINUE ENDIF 1502 CONTINUE SEGDES DESCR 1501 CONTINUE *C construction du tableau des duales * segini snomdu * do 325 il=1,nomin(/2) * NOMM =nomin(IL) * do 326 in = 1,lnomdd * if (NOMM.EQ.NOMDD(in)) then ** NODUA(il) =NOMDU(in) * goto 327 * endif *326 continue *327 continue *325 continue C WRITE(IOIMP,*) 'primales bloquees' ,(nomin(k),k=1,nomin(/2)) C WRITE(IOIMP,*) 'leurs duales ' ,(nodua(k),k=1,nomin(/2)) ncomp = nomin(/2) segini iccoun do 2000 ic = 1,ncomp segini iicpr iccoun(ic) = iicpr C WRITE(IOIMP,*) ' composante et son iicpr ',ic,iicpr 2000 continue ntplx = 0 C quels sont les noeuds concernes par des liaisons do 1700 i=1,IRIGEL(/2) MELEME=IRIGEL(1,I) SEGACT MELEME ipt4=meleme descr = irigel(3,i) segact descr xmatri= irigel(4,i) segact xmatri if (lisinc(/2).le.1) goto 1701 nomm = lisinc(2) C on l identifie par un numero ipo C pour recuperer les composantes ad hoc C quelle est sa position dans nomin do 3634 ipo=1,nomin(/2) if(NOMM.eq.nomin(ipo)) goto 3635 3634 continue 3635 continue C recup et comptage des noeuds supports de multiplicateurs ideb=2 iicpr = iccoun(ipo) do 1703 iel=1,num(/2) * xmatri=imattt(iel) * segact xmatri ip =num(noelep(ideb),iel) * WRITE(IOIMP,*) ' remplissage ip icpr(ip) ',ip,num(1,iel) icpr(ip)=num(1,iel) iinb = iinb+1 ivers(iinb)= ip cvers(iinb)= re(1,2,iel)*coerig(i) ntplx = ntplx+1 * WRITE(IOIMP,*) 'ip icpr(ip) ipo' ,ip,icpr(ip),ipo * segdes xmatri 1703 continue 1701 continue segdes descr,xmatri 1700 continue * WRITE(IOIMP,*) ' nombre de pts supports de LX ' ,ntplx C--------------------------------------------------------- * WRITE(IOIMP,*) 'ivers ' ,(ivers(k),k=1,iinb) C on ouvre le chpoint des reactions calculees par KU-F mchpoi = ipchp1 segact mchpoi nsoup1 = ipchp(/1) C initialisation du chpo de sortie support de ntplx points nat=1 nsoupo = 1 segini mchpo1 ipchp2= mchpo1 mchpo1.jattri(1) = 1 mchpo1.ifopoi= ifopoi mchpo1.mochde='CHAMP DE LX ISSU DE REMPLX' mchpo1.mtypoi='REMPLX' nc= 1 segini msoup1 mchpo1.ipchp(1)=msoup1 C nbelem = ntplx nbnn = 1 nbref = 0 nbsous=0 segini meleme msoup1.igeoc =meleme ipt1=meleme itypel= 1 n = ntplx msoup1.nocomp(1) = 'LX ' msoup1.noharm(1)= ifo segini mpova1 msoup1.ipoval = mpova1 inpp = 0 do 1000 isous=1,nsoup1 msoupo= ipchp(isous) segact msoupo meleme = igeoc segact meleme nc = nocomp(/2) mpoval=ipoval segact mpoval nptc = vpocha(/1) do 1010 icomp=1,nc nom2= nocomp(icomp) C recherche de l inconnue duale do 334 ipo=1,nomin(/2) * WRITE(IOIMP,*) ' nom de la composante et nodua ',nom2,NODUA(ipo) if(NOM2.eq.NODUA(ipo)) goto 335 334 continue C ce n est pas une composante depedante goto 1009 335 continue C WRITE(IOIMP,*) 'composante ->vpocha(1) ipo ' ,nom2 ,nptc,ipo iicpr = iccoun(ipo) C boucle sur les noeuds C WRITE(IOIMP,*) ' composante et son iicpr nbre ii ',ipo,iicpr,iinb segini siver2 C WRITE(IOIMP,*) 'num(1,il)',(num(1,il),il=1,nptc) C **************************************************** C [-DAVID-22/07/2004-] Inversion du tableau num suppression de la boucle 520 * do 500 k=1,iinb * ip = ivers(k) * do 520 lk=1,nptc * if(ip.eq.num(1,lk)) then * iver2(lk)=ip * cver2(lk)=cvers(k) * goto 500 * endif *520 continue *500 continue do lk = 1, nptc if ((num(1,lk).ge.1).and.(num(1,lk).le.nbpts)) then invnum(num(1,lk))=lk endif enddo do 500 k=1,iinb ip = ivers(k) lk = invnum(ip) if ((lk.ge.1).and.(lk.le.nptc)) then iver2(lk)=ip cver2(lk)=cvers(k) endif 500 continue C WRITE(IOIMP,*) 'iver2 ' ,(iver2(k),k=1,nptc) do 1020 j=1,nptc ip = iver2(j) if(ip.eq.0) goto 1020 if(icpr(ip).eq.0.or.iver2(j).eq.0) goto 1020 * on ne dicise plus par deux puisque simple multiplicateur xfo=-vpocha(j,icomp)/1.D0/cver2(j) * WRITE(IOIMP,*) ' ip inpp icpr ',ip,inpp,icpr(ip) ipt1.num(1,inpp+1) = abs(icpr(ip)) * pour avoir les LX au total icpr(ip)=-abs(icpr(ip)) mpova1.vpocha(inpp+1,1)=xfo C WRITE(IOIMP,*) 'ip icpr xfo ',ip,icpr(ip), C & xfo,lk,(inpp+1) inpp = inpp+1 1020 continue segsup siver2 1009 continue 1010 continue 1000 continue * on complete les LX do 1022 ic=1,nomin(/2) iicpr = iccoun(ic) do 1021 j=1,icpr(/1) if (icpr(j).le.0) goto 1021 * WRITE(IOIMP,*) ' complete j icpr(j) inpp num(/2) ', * > j,icpr(j),inpp,ipt1.num(/2) ipt1.num(1,inpp+1) = icpr(j) inpp=inpp+1 1021 continue 1022 continue * WRITE(IOIMP,*) ' on a ecrit ',inpp, ' LX' nbnn=ipt1.num(/1) nbelem=inpp nbsous=0 nbref=0 * WRITE(IOIMP,*) ' num mpova1 ',ipt1.num(/2),mpova1.vpocha(/1) if (nbelem.ne.ipt1.num(/2)) then * WRITE(IOIMP,*) ' remplx ajustement LX ' segadj ipt1 n=nbelem nc=1 segadj mpova1 endif do 3000 ic=1,nomin(/2) iicpr = iccoun(ic) segsup iicpr 3000 continue segsup iccoun,snomin,snomdu segdes mrigid END