C FX2LX SOURCE PV090527 26/04/30 21:15:35 12529 SUBROUTINE FX2LX(IPRIG1,ILMOT1,IPRIGI) C======================================================================== C MODIF DE RIGIDITE POUR TRANSFORMER LES INCONNUEs PRIMALEs FX EN LX C 27/07/2012 c IPRIG1 : MRIGID initial (avec composantes ILMOT1 = FX ...) c actif en entree c IPRIGI : MRIGID final (avec composante FLX) c actif en sortie C======================================================================== IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC CCREEL -INC PPARAM -INC CCOPTIO -INC SMCOORD -INC SMELEME -INC SMRIGID -INC SMLMOTS SEGMENT MTRAV INTEGER INC2LX(3,NBLX) ENDSEGMENT LOGICAL FLELIM CHARACTER*4 MOINC1,MOINC,MODUA1,MODUA * rem : dimension de itoto et jtoto en dur pour l'instant ... c INTEGER itoto(100),jtoto(100) INTEGER itoto(100) c----------------------------------------------------- c RECUPERATION DES ENTREES c----------------------------------------------------- MLMOT1 = ILMOT1 nmot1 = MLMOT1.MOTS(/2) RI1 = IPRIG1 NRIGE1 = RI1.IRIGEL(/2) segact mcoord*mod NBLX = 1000 segini,MTRAV nlx=0 c----------------------------------------------------- c PREPARATION DE LA RIGIDITE DE SORTIE c----------------------------------------------------- NRIGEL = 0 segini,MRIGID IPRIGI=MRIGID MTYMAT = RI1.MTYMAT c==== Boucle sur les sous rigidites ============================== DO 1000 ityty=1,NRIGE1 c call ZERO(INC2LX,3,NBLX) cbp -> routine ZERO seulement pour les reels DO Izero=1,3 DO Jzero=1,NBLX INC2LX(Izero,Jzero)=0 enddo enddo c------ Recup ------------------------- XCOE1 = RI1.COERIG(ityty) IPT1 = RI1.IRIGEL(1,ityty) DES1 = RI1.IRIGEL(3,ityty) XMATR1 = RI1.IRIGEL(4,ityty) NIFOU1 = RI1.IRIGEL(5,ityty) c------ combien d'inconnues sont a séparer ? -------------------- segact,DES1 NLIGP1 = DES1.LISINC(/2) nbinc1=0 FLELIM=.true. do 1010 iinc1=1,NLIGP1 c va t'on trouvé cette inconnue ? do imot1=1,nmot1 if(MLMOT1.MOTS(imot1).eq.DES1.LISINC(iinc1))then if(FLELIM)then nbinc1 = nbinc1 + 1 if(iimpi.ge.3) & write(ioimp,*) iinc1,'ieme inconnue ',MLMOT1.MOTS(imot1) & ,'detectee comme étant a remplacer par un LX ',nbinc1 goto 1010 else write(ioimp,*) iinc1,'ieme inconnue ',MLMOT1.MOTS(imot1) & ,'detectee comme étant a remplacer par un LX mal positionnée !' call ERREUR(21) endif endif enddo c on s arrete car on suppose toutes celles a trouvées sont au debut c goto 1011 c on va vérifier cette affirmation en continuant la boucle FLELIM=.false. 1010 continue 1011 continue if(FLELIM)then write(ioimp,*) 'On ne peut pas eliminer toutes les inconnues' call ERREUR(21) endif if(nbinc1.eq.0) goto 1000 c------ boucle sur les elements -------------------------------------- segact,IPT1 segact,XMATR1*mod NBNN1 = IPT1.NUM(/1) NBEL1 = IPT1.NUM(/2) do 1020 iel1=1,NBEL1 c-------- boucle sur les inconnues a remplacer -------------------- do 1021 iinc1=1,nbinc1 c -LX existe-il deja? (<=> a t'on deja vu cet noeud+inconnue?) ino1 = IPT1.NUM(iinc1,iel1) IBPTS=0 if(nlx.gt.0) then do ilx=1,nlx if (INC2LX(2,ilx).eq.ino1) then if (INC2LX(3,ilx).eq.imot1) then IBPTS = INC2LX(1,ilx) if(iimpi.ge.3) & write(ioimp,*) iinc1,'ieme inconnue ',DES1.LISINC(iinc1) & ,'detectee comme étant a remplacer par un LX ',nbinc1 goto 1022 endif endif enddo endif c -si ce LX n'existe pas il faut le créer et ajouter le irigel c on ajoute ce LX au tableau des inconnues a transformer NBPTS=NBPTS+1 nlx=nlx+1 if(nlx.gt.NBLX) then NBLX = NBLX + 1000 segadj,MTRAV endif INC2LX(1,nlx)=NBPTS INC2LX(2,nlx)=ino1 INC2LX(3,nlx)=imot1 c ajustement de irigel NRIGEL=NRIGEL+1 segadj,MRIGID COERIG(NRIGEL) = XCOE1 c remplissage du maillage (les noeuds) NBSOUS=0 NBREF=0 NBNN = NBNN1+1 NBELEM=1 segini,MELEME ITYPEL=22 NUM(1,1)=NBPTS inono=1 do inode=1,NBNN1 inono=inono+1 NUM(inono,1)=IPT1.NUM(inode,iel1) enddo IRIGEL(1,NRIGEL) = MELEME c segdes,MELEME c remplissage du DESCR + XMATRI c nbre d'inconnues = nbre initial + LX - celles qu'il faut enlever NLIGRP = NLIGP1+1-nbinc1 NLIGRD = NLIGRP NELRIG = 1 RIGREL=0 segini,DESCR,XMATRI LISINC(1)='LX ' LISDUA(1)='FLX ' NOELEP(1)= 1 NOELED(1)= 1 inono=1 c on remplit le terme Ktt relatif au LX RE(1,1,1) = XMATR1.RE(iinc1,iinc1,iel1) do iinc=(nbinc1+1),NLIGP1 inono=inono+1 LISINC(inono)=DES1.LISINC(iinc) LISDUA(inono)=DES1.LISDUA(iinc) c rem : on suppose qu'on a en entrée NOELEP = 1 2 1 2 3 4 5 6 c et qu'on tranforme en LX les deux premieres inconnues. c Pour etre + général il faudrait faire une boucle c et identifier avec meleme NOELEP(inono)=1+DES1.NOELEP(iinc) NOELED(inono)=1+DES1.NOELED(iinc) jnono=1 RE(inono,jnono,1)=XMATR1.RE(iinc,iinc1,iel1) RE(jnono,inono,1)=XMATR1.RE(iinc1,iinc,iel1) jnono=inono-1 do jinc=iinc,NLIGP1 jnono=jnono+1 RE(inono,jnono,1)=XMATR1.RE(iinc,jinc,iel1) RE(jnono,inono,1)=XMATR1.RE(jinc,iinc,iel1) cbp : on met a 0, meme si ces termes ne sont que des 0 c ou des 1 sur la diago pour eviter indeterminations.... XMATR1.RE(iinc,jinc,iel1)=0.d0 XMATR1.RE(jinc,iinc,iel1)=0.d0 enddo enddo IRIGEL(3,NRIGEL) = DESCR IRIGEL(4,NRIGEL) = XMATRI IRIGEL(5,NRIGEL) = NIFOU1 GOTO 1021 1022 continue c -si ce LX existe , il est ajoute au irigel ilx (=nrigel) MELEME = IRIGEL(1,ilx) DESCR = IRIGEL(3,ilx) XMATRI = IRIGEL(4,ilx) c - y a t-il de nouveau noeud dans le melem ? -> au moins 1 WX de plus ! c somme pour le Ktt du LX qui est obligatoirement en commun RE(1,1,1) = RE(1,1,1) + XMATR1.RE(iinc1,iinc1,iel1) c etape 1 : on remplit les tableaux de correspondance primal itoto c et dual jtoto (matrice RE d'entree -> de sortie) c boucle sur les inconnues primales de la matrice en entrée do 1023 iinc=(nbinc1+1),NLIGP1 itoto(iinc)=0 inoe1 = DES1.NOELEP(iinc) inum1 = IPT1.NUM(inoe1,iel1) MOINC1 = DES1.LISINC(iinc) c on cherche inono = inconnue du nouveau mrigid c qui a le meme noeud et meme nom d'inconnue do 1024 inono = 1,NOELEP(/1) MOINC = LISINC(inono) if(MOINC.ne.MOINC1) goto 1024 inoe = NOELEP(inono) inum = NUM(inoe,1) if(inum.ne.inum1) goto 1024 c cas 1 : cette inconnue primale est partagée c => on remplit le tableau de correspondance itoto(iinc)=inono goto 1023 1024 continue c cas 2 : il s'agit d'une nouvelle inconnue primale c => il faut la créer + on crée aussi la duale c (en espérant qu'on commence toujours dans le coin en haut a gauche c et qu'on ne décrit pas des "bouts" de matrice c = correspondance implicite primale-duale) NBNN = NUM(/1)+1 segadj,MELEME NUM(NBNN,1)=inum1 NLIGRP = NOELEP(/1)+1 NLIGRD = NLIGRP RIGREL=0 segadj,DESCR,XMATRI NOELEP(NLIGRP)=NBNN NOELED(NLIGRD)=NBNN LISINC(NLIGRP)=MOINC1 LISDUA(NLIGRD)=DES1.LISDUA(iinc) itoto(iinc)=NLIGRP 1023 continue c etape 2 : on fait la somme sur le triangle superieur et on symétrise c boucle sur les inconnues primales de la matrice en entrée do iinc=(nbinc1+1),NLIGP1 inono = itoto(iinc) c boucle sur les inconnues duales de la matrice en entrée do jinc=(nbinc1+1),iinc jnono = itoto(jinc) RE(jnono,inono,1) = RE(jnono,inono,1) & + XMATR1.RE(jinc,iinc,iel1) RE(inono,jnono,1) = RE(jnono,inono,1) enddo enddo 1021 continue c-------- fin de boucle sur les inconnues a remplacer ----------------- 1020 continue c------ fin de boucle sur les elements -------------------------------- 1000 CONTINUE c==== fin de Boucle sur les sous rigidites ======================== segadj,MCOORD c------------------------------- c MENAGE AVANT DE QUITTER c------------------------------- segsup,MTRAV C on desactive la sortie do iri=1,IRIGEL(/2) XMATRI = IRIGEL(4,iri) DESCR = IRIGEL(3,iri) MELEME = IRIGEL(1,iri) segdes,XMATRI,DESCR,MELEME enddo c on laisse MRIGID actif C on supprime l entree do iri=1,RI1.IRIGEL(/2) XMATRI = RI1.IRIGEL(4,iri) DESCR = RI1.IRIGEL(3,iri) MELEME = RI1.IRIGEL(1,iri) if(XMATRI.ne.0) segsup,XMATRI if(DESCR.ne.0) segsup,DESCR if(MELEME.ne.0) segsup,MELEME enddo segsup,RI1 RETURN END