C LISPK2 SOURCE CHAT 05/01/13 01:22:52 5004 SUBROUTINE LISPK2(XE,EPAI,V1,XMAT,XSTRS,XCAR,VAR,NSTRS, 1 NPOINT,MELE,XPREC,XEL,BPSS,REL,I70,I343,I157,I158,ILO11,KERRE) C======================================================================= C C EBERSOLT MARS 85 C ENTREES C XE(3,4) = COORDONNEES DE LA POUTRE LINESPRING C EPAI = EPAISSEUR NOEUDS 1 2 3 4 C V1(3) = VECTEUR ORIENTANT LES NOEUDS 1 2 3 4 C XMAT(15) = MATERIAU C XSTRS(NBGS*NSTRS) = CONTRAINTES DANS LE LINESPRING C XCAR(15) = CARACTERISTIQUES C VAR(NBGS*NSTRS) = CONTRAINTES DANS LE LINESPRING C NSTRS = NOMBRE DE CONTRAINTES C NPOINT = NOMBRE DE POINTS D INTEGRATION C MELE = 30 OU 50 NUMERO DE L ELEMENT C XPREC = PRECISION C TABLEAU DE TRAVAIL C XEL(3,3) = COORDONNEES LOCALES C BPSS(3,3) = MATRICE DE PASSAGE C SORTIES C REL(24,24) = MATRICE DE RIGIDITE AXES GLOBAUX C I70 = INDICERNABILITE DES 2 LEVRES C I343 = LA FISSURE DE PROFONDEUR NEGATIVE C I157 = LES 2 LEVRES SONT TROP ELOIGNEES C I158 = FISSURE TOTALEMENT TRAVERSANTE RIGIDITE NULLE C ILO11=-1 = EN DEHORS DE LA SURFACE DE CHARGE C 1 C EST O.K. C KERRE = 0 O.K. C 30 CONTRAINTE ULTIME NULLE C======================================================================= IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) PARAMETER(X774=.774596669241483D0) PARAMETER(IZERO=0) PARAMETER(EPS=1.D-3,PENA=1.D6,PENB=1.D2,EPSINV=1.D-3) PARAMETER(XZER=0,UNDEMI=.5D0,UN=1.D0,DEUX=2.D0,SIX=6.D0) PARAMETER(DOUZE=12.D0,TRSIX=36.D0,QUATRE=4.D0) C DIMENSION XE(3,*),REL(24,*),V1(*),BPSS(3,*),XEL(3,*) DIMENSION XSTRS(*),XMAT(*),XCAR(*),VAR(*) DIMENSION S(3),POIDS(3) C XPRECM = - XPREC * UNDEMI XPRECP = XPREC * UNDEMI ILO11=1 KERRE=0 C S(1)=-X774 S(2)= XZER S(3)= X774 POIDS(1)=5.D0/9.D0 POIDS(2)=8.D0/9.D0 POIDS(3)=5.D0/9.D0 C C MISE A XZER DE LA RIGIDITE ET DES INDICATEURS D ERREUR C CALL ZERO(REL,24,24) I70 =0 I343=0 I157=0 I158=0 C IF(XCAR(2).LT.XZER) THEN I343=1 FIS10=XZER ELSE FIS10=XCAR(2) ENDIF C IF(XCAR(12).LT.XZER) THEN I343=1 FIS30=XZER ELSE FIS30=XCAR(12) ENDIF C C EXTRACTION DE LA MATRICE DE PASSAGE C DO 100 IA=1,3 XEL(IA,1)=XE(IA,1) XEL(IA,2)=XE(IA,2) XEL(IA,3)=XE(IA,1)+V1(IA) 100 CONTINUE CALL VPAST(XEL,BPSS) DJA1=XZER DJA2=XZER DO 105 IA=1,3 DJA1=DJA1+(XE(IA,1)-XE(IA,4))*BPSS(3,IA) DJA2=DJA2+(XE(IA,2)-XE(IA,3))*BPSS(3,IA) 105 CONTINUE DJAC=DJA1*DJA2 IF(DJAC.LT.0.) I195=1 C C HAUT = LARGEUR ENTRE LES NOEUDS 1,4 ET 2,3 C HAUT=XZER XLARG1=XZER XLARG2=XZER DO 110 IA=1,3 HAUT =(XE(IA,2)-XE(IA,1))*(XE(IA,2)-XE(IA,1))+HAUT XLARG1=(XE(IA,4)-XE(IA,1))*(XE(IA,4)-XE(IA,1))+XLARG1 XLARG2=(XE(IA,3)-XE(IA,2))*(XE(IA,3)-XE(IA,2))+XLARG2 110 CONTINUE HAUT =SQRT(HAUT) XLARG1=SQRT(XLARG1) XLARG2=SQRT(XLARG2) EPS1=XLARG1/HAUT EPS2=XLARG2/HAUT IF(EPS1.GT.EPS.OR.EPS2.GT.EPS) I157=1 DJA1=DJA1/HAUT DJA2=DJA2/HAUT IF(DJA1.LT.1.D-3.AND.DJA2.LT.1.D-3) I70=1 ASUR1=FIS10/EPAI ASUR3=FIS30/EPAI ASUR0=(FIS10 + FIS30 ) / EPAI IF(ASUR1.GT..98.AND.ASUR3.GT..98) I158=1 IF(I158.EQ.1) GOTO 666 C C ON RECUPERE LES VALEURS DU MODULE D YOUNG C YOU = XMAT(1) XNU = XMAT(2) SIGY= XMAT(5) C C PENALISATION NORMALE C DDD = YOU * UNDEMI / ( UN - XNU * XNU ) PEWM=DDD *EPAI*PENA*HAUT/SIX PEWF=PEWM*EPAI*EPAI/DOUZE PEWM2=DEUX*PEWM PEWF2=DEUX*PEWF C C PENALISATION SOUS INTEGRE C PEWM15=DDD*EPAI*PENB*HAUT/QUATRE PEWF15=PEWM15*EPAI*EPAI/DOUZE C C PENALISATION DES TERMES CONCERNANT K I SI FISSURE INEXISTANTE C IF(ASUR0.GT.EPSINV) GOTO 366 REL(3 ,3 )=PEWM2 REL(4 ,4 )=PEWF2 REL(9 ,9 )=PEWM2 REL(10,10)=PEWF2 REL(3 ,9 )=PEWM REL(9 ,3 )=PEWM REL(10,4 )=PEWF REL(4 ,10)=PEWF GOTO 466 366 CONTINUE C C INTEGRATION NORMALE C X1=XZER X2=XZER X3=XZER X4=XZER X5=XZER X6=XZER X7=XZER X8=XZER X9=XZER DO 500 IA=1,NPOINT H1=UNDEMI-UNDEMI*S(IA) H2=UNDEMI+UNDEMI*S(IA) NCC = ( IA - 1 ) * 5 NSS = ( IA - 1 ) * NSTRS NVV = ( IA - 1 ) * 2 NMM = ( IA - 1 ) * 5 C ASURW=XCAR(NCC+2)/EPAI YOU = XMAT(NMM+1) XNU = XMAT(NMM+2) SIGY= XMAT(NMM+5) IF(SIGY.LE.XZER) KERRE=30 DDD = YOU * UNDEMI / ( UN - XNU * XNU ) CALL LISPAL(ASURW,ALMM,ALMF,ALFF,DELTA) DELTA=POIDS(IA)*DDD*HAUT*UNDEMI/DELTA C D11 = DELTA * ALFF D12 = DELTA * ALMF * EPAI / SIX D21 = DELTA * ALMF * EPAI / SIX D22 = DELTA * ALMM * EPAI * EPAI / TRSIX C C CALCUL DES DERIVEES C IF(SIGY.EQ.XZER) GOTO 111 CALL LISPPA(ASURW,EPAI,SIGY,GA,GB,A,B,C,D,E,F) XN = XSTRS(NSS+1) XM = XSTRS(NSS+4) C C VERIFICATION A L INTERIEUR DE LA SURFACE DE CHARGE OU PAS C CALL LISPQ(XN,XM,EPAI,SIGY,GA,GB,ASURW,Q) IF(VAR(NVV+1).EQ.XZER.AND.Q.LE.XZER) THEN ILOPL=0 ELSE IF(VAR(NVV+1).EQ.XZER.AND.Q.GT.XZER) THEN ILOPL=-1 ILO11=-1 ELSE IF(VAR(NVV+1).GT.XZER.AND.Q.LT.XPRECM) THEN ILOPL=0 ELSE IF(VAR(NVV+1).GT.XZER.AND.Q.GE.XPRECM.AND.Q.LE.XPRECP) THEN ILOPL=1 ELSE IF(VAR(NVV+1).GT.XZER.AND.Q.GT.XPRECP) THEN ILOPL=-1 ILO11=-1 ENDIF C C MATRICE DE RAIDEUR OU MATRICE TANGENTE C IF(ILOPL.EQ.1) THEN DFIDN = A * XN + B * XM + E DFIDM = B * XN + D * XM + F U = D11 * DFIDN + D12 * DFIDM V = D21 * DFIDN + D22 * DFIDM C DENOM = U * DFIDN + V * DFIDM D11 = D11 - U * U / DENOM D12 = D12 - U * V / DENOM D21 = D21 - V * U / DENOM D22 = D22 - V * V / DENOM ENDIF 111 CONTINUE C X1=X1+H1*H1*D11 X2=X2-H1*H1*D12 X3=X3+H1*H1*D22 C X4=X4+H1*H2*D11 X5=X5-H1*H2*D12 X6=X6+H1*H2*D22 C X7=X7+H2*H2*D11 X8=X8-H2*H2*D12 X9=X9+H2*H2*D22 500 CONTINUE C C MISE EN PLACE DANS LA MATRICE DE RIGIDITE C REL(3 ,3 )=X1 REL(3 ,4 )=X2 REL(4 ,3 )=X2 REL(4 ,4 )=X3 C REL(9 ,3 )=X4 REL(9 ,4 )=X5 REL(10,3 )=X5 REL(10,4 )=X6 C REL(3 ,9 )=X4 REL(3 ,10)=X5 REL(4 ,9 )=X5 REL(4 ,10)=X6 C REL(9 ,9 )=X7 REL(9 ,10)=X8 REL(10,9 )=X8 REL(10,10)=X9 C C PENALISATION DES TERMES NE CONCERNANT PAS K I C 466 CONTINUE C IF(MELE.EQ.30) THEN REL(1 ,1 )=PEWM2 REL(2 ,2 )=PEWM2 REL(6 ,6 )=PEWF2 C REL(7 ,7 )=PEWM2 REL(8 ,8 )=PEWM2 REL(12,12)=PEWF2 C REL(1 ,7 )=PEWM REL(7 ,1 )=PEWM REL(2 ,8 )=PEWM REL(8 ,2 )=PEWM REL(6 ,12)=PEWF REL(12,6 )=PEWF C ELSE IF(MELE.EQ.50) THEN REL(1 ,1 )=PEWM15 REL(2 ,2 )=PEWM15 REL(6 ,6 )=PEWF15 C REL(7 ,7 )=PEWM15 REL(8 ,8 )=PEWM15 REL(12,12)=PEWF15 C REL(1 ,7 )=PEWM15 REL(7 ,1 )=PEWM15 REL(2 ,8 )=PEWM15 REL(8 ,2 )=PEWM15 REL(6 ,12)=PEWF15 REL(12,6 )=PEWF15 ENDIF C C DOUBLE SYMETRISATION A PARTIR D UNE MATRICE 12 12 ON A UNE 24 24 C DO 900 IA=1,6 DO 900 IB=1,6 C REL(IA+18,IB+18)= REL(IA ,IB ) REL(IA ,IB+18)=-REL(IA ,IB ) REL(IA+18,IB )=-REL(IA ,IB ) C REL(IA+12,IB+12)= REL(IA+6,IB+6) REL(IA+6 ,IB+12)=-REL(IA+6,IB+6) REL(IA+12,IB+6 )=-REL(IA+6,IB+6) C REL(IA+12,IB+18)= REL(IA+6,IB ) REL(IA+18,IB+12)= REL(IA+6,IB ) C REL(IA ,IB+12)=-REL(IA+6,IB ) REL(IA+12,IB )=-REL(IA+6,IB ) C REL(IA+18,IB+6 )=-REL(IA+6,IB ) REL(IA+6 ,IB+18)=-REL(IA+6,IB ) C 900 CONTINUE C C CHANGEMENT DU REPERE EN FONCTION DE BPSS C CALL TRANSK(REL,BPSS,24,4,IZERO) C 666 CONTINUE RETURN END