C SUPDEP SOURCE MB234859 26/06/10 21:15:57 12569 SUBROUTINE SUPDEP c================================================================= c cette procedure est appelée par SUPER c A partir du champ de deplacements interface et du champ d efforts c sur la sous structure, elle determine le champ de déplacement c sur toute la sous-structure c================================================================= IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC SMSUPER -INC SMELEME -INC PPARAM -INC CCOPTIO -INC SMMATRI -INC SMCHPOI -INC SMVECTD -INC SMRIGID -INC CCREEL c ???????????????????????????????????????????????????????????????? SEGMENT/BID/(BIDON(IIMAX+10)*D) c ???????????????????????????????????????????????????????????????? c de la meme facon que dans MONDES , on va charger la maximum de c lignes en memoire pendant que l'on va gerer les efforts c IPLIG : première ligne en mémoire c IDLIG : dernière ligne en mémoire c---------------------------------------------------------------- PARAMETER (LPCRAY=10000) segment ITRAA(NENS) integer OOOVAL logical leffort character*4 mcle(1) data mcle/'NOER'/ dnorma=0.d0 dnormb=0.d0 c creation d'une pile MRU call OOOMRU(1) call lirobj('SUPERELE',MSUPER,1,IRETOU) if (ierr.ne.0) RETURN c lecture du déplacement interface call lirobj('CHPOINT ',MDEPI,1,IRETOU) call actobj('CHPOINT ',MDEPI,1) if (ierr.ne.0) RETURN c lecture du champ d'efforts si il existe c 27/11/2009 lecture obligatoire car risque d'erreur utilisateur c due a une mauvaise comprehension de l'operation call lirobj('CHPOINT ',MFORC,1,IRETOU) call actobj('CHPOINT ',MFORC,1) if (ierr.ne.0) RETURN if (iretou .eq. 0) then leffort = .false. else leffort = .true. end if noer=0 call lirmot(mcle,1,noer,0) segact MSUPER ** write(6,*) MRIGTO,MSUPEL,MSURAI,MBLOQU,MSUMAS,MCROUT if (MCROUT.EQ.0) then * pas de super element, on rend les LX du champ d'entree CALL EXCOPP(MDEPI,'LX ',0,MDEPSO,'LX ',0,1) NAT=2 NSOUPO=0 call ecrobj('CHPOINT',MDEPSO) return endif c c recherche du nombre d'inconnues maitres MRIGID = MSURAI segact MRIGID xMATRI = IRIGEL(4,1) lagdua=msuper.islag * write (6,*) ' msurai lagdua dans supdep ', mrigid,lagdua segdes MRIGID segact xMATRI * XMATRI = IMATTT(1) * segdes IMATRI * segact XMATRI nligra = RE(/1) segdes XMATRI c MCROUX = MCROUT if(mcroux.eq.0) call erreur(1123) if (ierr.ne.0) return * creation du meleme des noeuds maitres MRIGID=MRIGTO SEGACT MRIGID meleme=msupel MRIGID = MSURAI c sauvegarde du deplacement interface call reduir(MDEPI,MELEME,MDEPint) call adchpo(mdepi,mdepint,mdext,1.d0,-1.d0) * call ecchpo(mdepi,0) * call ecchpo(mdepint,0) * write (6,*) ' mdext ' * call ecchpo(mdext,0) c transformation du champ de déplacement en vecteur * call ecmail(lagdua,0) ** call dbbch(mdepint,lagdua) call chv1(MCROUX,MDEPInt,MVECTX,1) c normalisation MMATRI = MCROUT segact MMATRI MDNOR = IDNORM segact MDNOR INC = DNOR(/1) c inbine : intger nombre inconnues esclaves inbine = INC - Nligra * write (6,*) ' inbine inc nligra ',inbine,inc,nligra MVECTD = MVECTX segact MVECTD*mod dnormb= 0.D0 do 1 ii1 = inbine+1,INC VECTBB(ii1) = VECTBB(ii1) / DNOR(ii1) ** dnormb= max(dnormb,abs(VECTBB(ii1))) 1 continue ** dnormb = dnormb * xzprec*xzprec dnormb = xpetit / xzprec MVECT1 = MVECTD MILIGN = IILIGN segact MILIGN NNOE = ILIGN(/1) c ????? idem que dans MONDES ?????? LTRK = MAX(1+LPCRAY,OOOVAL(1,4)) IIMAX = (((IJMAX+LTRK)/LTRK)+1)*LTRK c *********************************************************************** *********************************************************************** c pb à résoudre : L1t X + L2t DEPI = D(-1) L1(-1) F c * commencons par traiter le terme en effort c transformation du CHPOINT en vecteur if (leffort) then MCHPOI = MFORC MRIGID = MRIGTO segdes MRIGID call copie2(mchpoi,mchpo1) SEGACT MCHPO1 DO 432 I=1,mchpo1.IPCHP(/1) MSOUPO=mchpo1.IPCHP(I) SEGACT MSOUPO*MOD IPT4=IGEOC SEGINI,ipt5=ipt4 SEGDES ipt4 IGEOC=ipt5 432 CONTINUE call dbbch(mchpo1,lagdua) * call ecchpo(mchpo1 ,0) call chv2(MCROUX,MCHPO1,MVECTX,1) MVECTD = MVECTX c attention CHV2 desactive tout segact MMATRI segact MILIGN segact MVECTD*MOD MDIAG = IDIAG segact MDIAG c c il faut normaliser ce vecteur c on va de plus recuperer l'indice du premier terme non nul dnorma = 0.D0 inbi=vectbb(/1) * write (6,*) ' inbine ',inbine * write (6,*) ' vectbb-1 ',(vectbb(i),i=1,vectbb(/1)) * write (6,*) ' dnor ',(dnor (i),i=1,vectbb(/1)) do 2 ii1=1,inbine VECTBB(ii1) = VECTBB(ii1) * DNOR(ii1) ** dnorma = max(dnorma,abs(VECTBB(ii1))) 2 continue * write (6,*) ' vectbb-2 ',(vectbb(i),i=1,vectbb(/1)) ** dnorma = dnorma * xzprec*xzprec dnorma = xpetit/xzprec c c recherche du premier terme non nul do 3 ii1=1,inbine if (abs(VECTBB(ii1)).GE.dnorma) GOTO 4 3 continue * write(6,*) ' attention vecteur force nulle' 4 continue ipremf = ii1 if(dnorma.eq.0.d0) ipremf=max(1,inbine) * effectuons maintenant le produit (L1)-1 EFFORT *------------------------------------------------- c ???????????? segini BID ivalma = 0 c ???????????? c d'ou le bloc associé INPREM = IPNO(ipremf) c et le bloc de la dernière ligne INDERn=-1 if(inbine.ne.0)INDERN = IPNO(inbine) c IPLIG = INPREM do 10 ii0=INPREM,INDERN LIGN = ILIGN(ii0) segact /ERR=20/ LIGN IPRELL = IPREL IVALMA = IVALMA+VAL(/1) *pvpv if (IVALMA.GT.NGMAXY) GOTO 20 NA = IMMM(/1) call supde2(IPPVV(1),IVPO(1),VAL(1),VECTBB(1), > na,inumli,inbine,ipremf,iprel,dnorma) 10 continue segsup BID IDLIG = INDERN GOTO 60 c on a eu des problèmes de memoire 20 continue SEGSUP BID IDLIG = ii0 - 1 itemp1 = ii0 c c'est reparti do 30 ii0=itemp1,INDERN LIGN = ILIGN(ii0) segact /ERR=22/ LIGN NA = IMMM(/1) IPRELL = IPREL call supde2(IPPVV(1),IVPO(1),VAL(1),VECTBB(1), > na,inumli,inbine,ipremf,iprel,dnorma) segdes LIGN*(NOMOD,MRU) GOTO 30 c il y a encore des problèmes 22 CONTINUE c il va falloir faire de la place ==> desactivation d'une ligne c reste-t-il des lignes à desactiver ? if (IDLIG .lt. IPLIG) then CALL ERREUR(5) else LIGN=ILIGN(IDLIG) SEGDES LIGN*(NOMOD,MRU) IDLIG=IDLIG-1 end if 30 continue c c muliplions maintenant par D-1 c--------------------------------- 60 continue do 70 i=1,inbine VECTBB(i) = VECTBB(i) * DIAG(i) 70 continue segdes MDIAG else c il n y a pas d'efforts segini MVECTD c il faut preciser qu il n y a aucune ligne chargée IDLIG = 0 IPLIG = NNOE end if c c *********************************************************************** *********************************************************************** c Il faut maintenant effectuer le calcul L1t X1 + L2t X2 = Nouveau F c il ne s'agit que d'une remontée c c on va en profiter pour compter les mouvements d'ensemble iaa = 0 segini itraa c c inumli : numero de la ligne en cours inumli = INC do 120 ii0=NNOE,1,-1 LIGN = ILIGN(ii0) 122 continue if ((ii0.gt.IDLIG).or.(ii0.lt.IPLIG)) then segact /ERR=124/ LIGN else IDLIG = IDLIG - 1 end if NA = IMMM(/1) IFIB=IVPO(/1) call supde1(IPPVV(1),IVPO(1),VAL(1),VECTBB(1), & MVECT1.VECTBB(1),na,inumli,inbine,iprel,ifib,dnormb) do ibb=1,NA if (IMMM(ibb) .ne. 0) then iaa = iaa+1 itraa(iaa)=iprel+ibb-1 end if end do segdes LIGN*(NOMOD,MRU) GOTO 120 124 CONTINUE c encore des problèmes mémoires if (IDLIG .lt. IPLIG) then CALL ERREUR(5) else LIG1=ILIGN(IDLIG) SEGDES LIG1*(NOMOD,MRU) IDLIG=IDLIG-1 GOTO 122 end if 120 continue segsup MVECTD MVECTD = MVECT1 c ******************************************************************************* ******************************************************************************* c gestion des déplacements de corps rigide c meme chose que dans MONDES c ------ c if (nens .ne. 0) then MINCPO = IINCPO MIMIK = IIMIK segact MINCPO,MIMIK ipt2 = IGEOMA segact ipt2 NNOE = INCPO(/2) IINC1=INCPO(/1) c XMA = xpetit XMAL = xpetit inan=0 do kk=1,INC if (NOER.EQ.0.OR.(noer.eq.1.and.abs(vectbb(kk)).lt.xgrand)) & goto 500 inan = inan + 1 vectbb(kk)=0.D0 500 continue if (ittr(kk).eq.0) then XMA=MAX(XMA,ABS(VECTBB(kk))) else XMAL=MAX(XMAL,ABS(VECTBB(kk))) endif end do XMA = XMA * 1.d-10 XMAL = XMAL * 1.d-10 xmal = max(xma*1d-2,xmal) * write (6,*) ' supdep cma cmal ',xma,xmal c boucle sur les mouvements d'ensemble do 200 ia=1,NENS i1=itraa(ia) j=IPNO(i1) do 210 k=1,iinc1 if(INCPO(K,J).eq.i1) goto 220 210 continue call erreur(5) return 220 continue if ((ittr(i1).eq.0).and.(ABS(VECTBB(i1)).le.XMA)) GOTO 250 if ((ittr(i1).ne.0).and.(ABS(VECTBB(i1)).le.XMAL)) GOTO 250 MOTERR(1:4)=IMIK(k) INTERR(1)=ipt2.NUM(1,J) write (6,*) ' vectbb) ',vectbb(i1) ** CALL ERREUR(149) ** RETURN call soucis(149) 251 continue 250 continue jjk = ipt2.NUM(1,J) IF(ITTR(I1).EQ.0) WRITE(IOIMP,280) JJK,IMIK(K) IF (IIMPI.NE.0 .AND. ITTR(I1).NE.0) & WRITE(IOIMP,290) JJK,IMIK(K) 200 continue 280 FORMAT(' INDETERMINATION DETECTEE AU NOEUD ',I6,' INCONNUE ', * A4,/,' INDETERMINATION LEVEE PAR LA MISE A ZERO DE ', * 'LA SUSDITE') 290 FORMAT(' INDETERMINATION ENTRE CONDITIONS IMPOSEES DETECTEE ', * 'AU NOEUD ',I6,' INCONNUE ',A4,/,' INDETERMINATION LEVEE ', * 'PAR LA SUPPRESSION DE LA CONDITION REDONDANTE ') segdes MINCPO,MIMIK segdes ipt2 end if c ******************************************************************************* ******************************************************************************* * un petit coup de normalisation do 300 ii1=1,INC VECTBB(ii1) = VECTBB(ii1) * DNOR(ii1) 300 continue segdes MDNOR segdes MVECTD MVECTX = MVECTD MMATRX = MMATRI MRIGTX = MRIGTO * write(6,*) ' mrigto mmatri mvectx ', mrigto,mmatri,mvectx c il faut transformer ce vecteur en chpoint call VCH1(MMATRX,MVECTX,ISOLU,MRIGTX) if (lagdua.ne.0) call dbbcf(isolu,lagdua) ** write (6,*) ' mdext ' ** call ecchpo(mdext,0) ** write (6,*) ' isolu ' ** call ecchpo(isolu,0) call adchpo(isolu,mdext,mchpoi,1.d0,1.d0) c il faut ajuster le type du champ * mchpoi=isolu segact MCHPOI*mod JATTRI(1)=1 segdes MMATRI c il faut maintenant rajouter les déplacements imposés éliminés (jrcond) MRIGID = MRIGTO segdes MRIGID c segdes MSUPER c on rajoute les multiplicateurs interfaces call actobj('CHPOINT ',mchpoi,1) call ecrobj('CHPOINT ',mchpoi) c désactivation de la pile MRU call OOOMRU(0) return end