C RELABA SOURCE FANDEUR 22/01/03 21:15:40 11237 SUBROUTINE RELABA * * relation barycentrique pour les ddl d'un noeud vis-à-vis * d'un maillage * rig1 = rela bary lmot1 (ou 'DEPL' ou 'ROTA') p1 geo1 * * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMELEME -INC SMCOORD -INC SMRIGID -INC CCHAMP -INC SMLREEL -INC SMLMOTS c CHARACTER*4 ITCORI(2),LEMOT,LESDDL(6),LESDUA(6) CHARACTER*4 MODEPL(5),MODEDU(5),MOROTA(5),MORODU(5) DATA ITCORI(1)/'DEPL'/ DATA ITCORI(2)/'ROTA'/ DATA MODEPL / 'UX ','UY ','UZ ','UR ','UT ' / DATA MODEDU / 'FX ','FY ','FZ ','FR ','FT ' / DATA MOROTA / 'RX ','RY ','RZ ','RT ','RS ' / DATA MORODU / 'MX ','MY ','MZ ','MT ','MS ' / CALL LIROBJ('LISTMOTS',IP0,0,IRETOU) if (IP0.eq.0) then CALL LIRMOT(ITCORI,2,IMOT,0) if (imot.eq.0) then call erreur(5) return else if (imot.eq.1) then if (ifour.eq.2) then nosddl = 3 lesddl(1) = modepl(1) lesddl(2) = modepl(2) lesddl(3) = modepl(3) else endif CALL LIRMOT(ITCORI,2,IMOT,0) if (imot.eq.2) then if (ifour.eq.2) then nosddl = 6 lesddl(4) = morota(1) lesddl(5) = morota(2) lesddl(6) = morota(3) else endif endif else CALL LIRMOT(ITCORI,2,IMOT,0) if (imot.eq.1) then if (ifour.eq.2) then nosddl = 6 iddl = 3 else endif else if (ifour.eq.2) then nosddl = 3 iddl = 0 else endif endif if (ifour.eq.2) then lesddl(iddl + 1) = morota(1) lesddl(iddl + 2) = morota(2) lesddl(iddl + 3) = morota(3) else endif endif else mlmots = ip0 segact mlmots jgn = mots(/2) do 11 imo = 1,jgn do jde =1,5 if (mots(imo).eq.modepl(jde)) then lesddl(imo) = modepl(jde) lesdua(imo) = modedu(jde) goto 11 endif enddo do jde = 1,5 if (mots(imo).eq.morota(jde)) then lesddl(imo) = morota(jde) lesdua(imo) = morodu(jde) goto 11 endif enddo c le mot n est pas un ddl call erreur(5) return 11 continue nosddl = jgn endif CALL LIROBJ('POINT',IP1,1,IRETOU) CALL LIROBJ('MAILLAGE',IP2,1,IRETOU) meleme = ip2 segact meleme if (itypel.ne.1) call change(ip2,1) meleme = ip2 segact meleme nbele1 = num(/2) ipt1 = ip2 CALL LIROBJ('LISTREEL',IP3,0,IRETOU) if (iretou.eq.1) then mlreel = ip3 segact mlreel jg = prog(/1) if (jg.ne.nbele1) then c autant de coef que de points call erreur(5) return endif som1 = prog(1) do j = 2,jg som1 = som1 + prog(j) enddo if (som1.eq.0.D0) then c somme des coefs nulle call erreur(5) return endif else jg = 1 endif * cree multiplicateur(s) segact mcoord*mod NBPTI=nbpts NBPTS = NBPTI + nosddl segadj mcoord do j = 1,nosddl xcoor((nbpti - 1 + j)*(idim + 1) + 1) = 0.d0 xcoor((nbpti - 1 + j)*(idim + 1) + 2) = 0.d0 if (idim.eq.3) xcoor((nbpti - 1 + j)*(idim + 1) + 3) = 0.d0 xcoor((nbpti + j)*(idim + 1)) = 0.d0 enddo * cree rigidite NRIGE = 6 NRIGEL = nosddl segini mrigid ICHOLE=0 IMGEO1=0 IMGEO2=0 ISUPEQ=0 IFORIG=IFOUR MTYMAT='RIGIDITE' NLIGRP=nbele1 + 2 NLIGRD=nbele1 + 2 nelrig=1 segini xmatri * nelrig = 1 * segini imatri * imattt(1) = xmatri re(1,1,1) = 0.d0 if (jg.eq.1) then re(1,2,1) = 1.D0/nbele1 re(2,1,1) = re(1,2,1) do l = 1, nbele1 re(1,2 + l,1) = -1.D0 re(2+l,1,1) = -1.D0 enddo else re(1,2,1) = 1.D0/som1 re(2,1,1) = re(1,2,1) do l = 1, nbele1 re(1,2 + l,1) = -1.D0*prog(l) re(2+l,1,1) = re(1,2+l,1) enddo endif segdes xmatri do ir = 1,nosddl ipmu = NBPTI + ir nbnn = nbele1 + 2 nbelem = 1 nbsous = 0 nbref = 0 segini meleme itypel = 22 num(1,1) = ipmu num(2,1) = ip1 segact ipt1 do in = 1,nbele1 num(2+in,1) = ipt1.num(1,in) enddo icolor(1) = idcoul segdes meleme SEGINI DESCR NOELEP(1)= 1 NOELED(1)= 1 LISINC(1)='LX' LISDUA(1)='FLX' do l = 1,nbele1+1 LISINC(1 + l)=lesddl(ir) LISDUA(1 + l)=lesdua(ir) NOELEP(1+l)= 1 + l NOELED(1+l)= 1 + l enddo SEGDES DESCR coerig(ir) = 1.d0 IRIGEL(2,ir) = 0 IRIGEL(5,ir) = NIFOUR IRIGEL(6,ir) = 0 IRIGEL(1,ir) = meleme IRIGEL(3,ir) = descr IRIGEL(4,ir) = xmatri enddo segdes mrigid CALL ECROBJ('RIGIDITE',mrigid) RETURN END