C SIGMA2 SOURCE OF166741 25/02/21 21:18:35 12166 SUBROUTINE SIGMA2(IPMAIL,IVADEP,IVACAR,NELMAT,NBGMAT, & IVAMAT,LHOOK,IMAT,MATE,CMATE,NMATT,NSTRS,MFR,IPMINT, & IPMIN1,NDEP,NBPGAU,NBPTEL,MELE,LRE,LW,IREPS2,NPINT,IVASTR & ,UZDPG,RYDPG,RXDPG,IIPDPG,inoer) *---------------------------------------------------------------------* * __________________________ * * | | * * | calcul des contraintes| * * |________________________| * * * * coq3,dkt,coq4,coq8,coq2 ,dst,joint 3d,joints 2d * * * *---------------------------------------------------------------------* * * * entrees : * * ________ * * * * ipmail pointeur sur un segment meleme * * ivadep pointeur sur le chamelem de deplacements * * ivacar pointeur sur les chamelems de caracteristiques * * nelmat taille maxi des melval du materiau (no d'element) * * nbgmat taille maxi des melval du materiau (pt de gauss) * * ivamat pointeur sur un segment mptval pour le materiau ou * * lhook dimension de la matrice de hooke * * imat (2 il y a une matrice de hooke,1 non ) * * mate numero du materiau * * cmate nom du materiau * * nmatt nombre de composante de materiau (imat=1) * * nstrs nombre de composante de contraintes/deformations * * pour une matrice de hooke * * mfr numero de formulation de l'element fini * * ipmint pointeur sur un segment minte * * ipmin1 pointeur sur un segment minte (aux noeuds) * * ndep nombre de composantes de deplacements * * nbpgau nombre de point d'integration pour la rigidite * * nbptel nombre de points par element * * mele numero de l'element fini * * lre nombre de ddl dans la matrice de rigidite * * lw dimension du tableau de travail de l'element * * iresp2 flag pour indiquer si on veut les contraintes * * de piola-kirchhoff * * npint nombre de points d'integration dans l'epaisseur * dans le cas des elements de coque integres * * * sorties : * * ________ * * * * ivastr pointeur sur un segment mptval contenant les * * les melvals de contraints * * *---------------------------------------------------------------------* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC CCREEL -INC SMCHAML -INC SMINTE -INC SMELEME -INC SMCOORD -INC SMLREEL -INC TMPTVAL SEGMENT WRK1 REAL*8 DDHOOK(LHOOK,LHOOK) ,XDDL(LRE) ,XSTRS(NSTRS) REAL*8 XE(3,NBBB) ,DDHOMU(LHOOK,LHOOK) ENDSEGMENT * SEGMENT WRK2 REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE) ENDSEGMENT * SEGMENT WRK3 REAL*8 WORK(LW) ENDSEGMENT * SEGMENT WRK4 REAL*8 BPSS(3,3) ,XEL(3,NBBB) ,XDDLOC(LRE) ENDSEGMENT * SEGMENT WRK5 REAL*8 XSTRS1(NSTRS1) ENDSEGMENT * SEGMENT,MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT CHARACTER*8 CMATE dimension rel(lre,lre) * * initialisation du point autour duquel se fait le mouvement * en deformation plane generalisee * IF (IFOUR.EQ.-3) THEN IP=IIPDPG SEGACT MCOORD IREF=(IP-1)*(IDIM+1) XDPGE=XCOOR(IREF+1) YDPGE=XCOOR(IREF+2) ELSE XDPGE=0.D0 YDPGE=0.D0 ENDIF * MELEME=IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) * NV1=NMATT SEGINI,MVELCH * NHRM=NIFOUR * MINTE=IPMINT IRTD=1 * NBBB=NBNN SEGINI WRK1 c_______________________________________________________________________ c c numero des etiquettes : c etiquettes de 1 a 98 pour traitement specifique a l element c dans la zone specifique a chaque element commencant par : c 5 continue c element 5 etiquettes 1005 2005 3005 4005 ... c 44 continue c element 44 etiquettes 1044 2044 3044 4044 ... c_______________________________________________________________________ c GOTO(99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 1 99,99,99,99,99,99,27,28,99,99,99,99,99,99,99,99,99,99,99,99, 2 41,99,99,44,28,99,99,99,49,99,99,99,99,99,99,41,99,99,99,99, 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 4 99,99,99,99,85,86,87,88,99,99,99,99,93,99,99,99,99),MELE * GOTO(168,169,170,171,172),MELE-167 * GOTO 99 c_______________________________________________________________________ c c element coq3 c_______________________________________________________________________ c 27 CONTINUE SEGINI WRK3 c c boucle de calcul pour les differents elements c DO 3027 IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO 4027 IGAU=1,NBNN DO 4027 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4027 CONTINUE c c on cherche les coordonnees des noeuds de l element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c c on cherche les coeff des mat de hooke et l epaisseur c MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) EPAIST=VELCHE(1,IBMN) ELSE EPAIST=0.D0 ENDIF c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOMU) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) THEN DO 9027 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9027 CONTINUE CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) ENDIF CALL COQ3ST(XE,XDDL,XSTRS,DDHOMU) c IF(IREPS2.EQ.1) 1 CALL DBCO32(XE,DDHOMU,XDDL,WORK,XSTRS) c MPTVAL=IVASTR DO 6027 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB,VELCHE(/2)) VELCHE(1,IBMN)=XSTRS(ICOMP) 6027 CONTINUE c 3027 CONTINUE c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9927 CONTINUE SEGSUP WRK3 GOTO 510 c____________________________________________________________________ c c element dkt c____________________________________________________________________ c 28 CONTINUE NBNO=NBNN SEGINI WRK2,WRK4 IF(NPINT.NE.0)THEN NSTRS1=6 SEGINI WRK5 ENDIF DO 3028 IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO 4028 IGAU=1,NBNN DO 4028 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4028 CONTINUE c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL VPAST(XE,BPSS) c bpss stocke la matrice de passage CALL VCORLC (XE,XEL,BPSS) CALL MATVEC(XDDL,XDDLOC,BPSS,6) c c on cherche les epaiseurs et on les moyenne, c les excentrements et on les moyenne. c EPAIST=0.D0 MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EPAIST=EPAIST+VELCHE(IGMN,IBMN) ENDDO EPAIST=EPAIST/NBPGAU ENDIF * EXCEN=0.D0 MELVAL=IVAL(2) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EXCEN=EXCEN+VELCHE(IGMN,IBMN) ENDDO EXCEN=EXCEN/NBPGAU ENDIF c IF(NPINT.EQ.0)THEN c c coque global c c boucle sur les points de gauss c DO 5028 IGAU=1,NBPTEL CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, & MELE,MFR,NBNO,LRE,IFOUR,NSTRS,0,1.D0,XEL, & SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) * * on modifie la matrice b en cas d'excentrement non nul * IF (EXCEN.NE.0.D0) THEN DO 1528 IJL=1,3 DO 1528 IJC=1,LRE BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC) 1528 CONTINUE ENDIF c c on cherche la matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOMU) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO 9128 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9128 CONTINUE CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) ENDIF CALL DBST(BGENE,DDHOMU,XDDLOC,LRE,NSTRS,XSTRS) c c calcul des eps 2 c IF(IREPS2.EQ.1) 1 CALL DBDKT2(XEL,DDHOMU,XDDLOC,IGAU,XSTRS,SHPWRK,SHPTOT, 1 BGENE,NBNO,LRE,NSTRS) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO 9028 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XSTRS(ICOMP) 9028 CONTINUE 5028 CONTINUE c ELSE c c coque integree c NBPGA1=NBPGAU/NPINT c c boucle sur les points de gauss de la surface c DO 5001 IGAU=1,NBPGA1 CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, & MELE,MFR,NBNO,LRE,IFOUR,NSTRS1,0,1.D0,XEL, & SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) * * on modifie la matrice b en cas d'excentrement non nul * IF (EXCEN.NE.0.D0) THEN DO 1501 IJL=1,3 DO 1501 IJC=1,LRE BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC) 1501 CONTINUE ENDIF c c boucle sur les nappes c DO 5002 INAP=1,NPINT IGAU1=(INAP-1)*NBPGA1+IGAU c c on cherche la matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU1.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU1,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU1.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO 9101 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU1,VELCHE(/1)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9101 CONTINUE CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF CALL DBST(BGENE,DDHOOK,XDDLOC,LRE,NSTRS1,XSTRS1) c c calcul des eps 2 c IF(IREPS2.EQ.1) 1 CALL DBDKT2(XEL,DDHOOK,XDDLOC,IGAU,XSTRS1,SHPWRK,SHPTOT, 1 BGENE,NBNO,LRE,NSTRS1) c ZZZ=DZEGAU(IGAU1)*(EPAIST/2.D0) XSTRS(1)=XSTRS1(1)+ZZZ*XSTRS1(4) XSTRS(2)=XSTRS1(2)+ZZZ*XSTRS1(5) XSTRS(3)=0.D0 XSTRS(4)=XSTRS1(3)+ZZZ*XSTRS1(6) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO 9001 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU1,IBMN)=XSTRS(ICOMP) 9001 CONTINUE c fin de boucle sur les nappes de points 5002 CONTINUE c fin de boucle sur les points dans chaque nappe 5001 CONTINUE c fin de boucle sur les points d'integration ENDIF c fin de boucle sur les elements 3028 CONTINUE * IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9928 CONTINUE SEGSUP,WRK2,WRK4 IF(NPINT.NE.0)SEGSUP WRK5 * GOTO 510 c____________________________________________________________________ c c elements coq6 et coq8 c____________________________________________________________________ c 41 CONTINUE NBNO=NBNN SEGINI WRK2,WRK3 MINTE1=IPMIN1 SEGACT MINTE1 NBPGA1=MINTE1.SHPTOT(/3) NBN1 =MINTE1.SHPTOT(/2) c c boucle de calcul pour les differents elements c DO 3041 IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO 4041 IGAU=1,NBNN DO 4041 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4041 CONTINUE c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c c on cherche les epaisseurs et les excentrements, c MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) WORK(IGAU)=VELCHE(IGMN,IBMN) ENDDO ENDIF * MELVAL=IVAL(2) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) WORK(IGAU+10)=VELCHE(IGMN,IBMN) ENDDO ENDIF c c determination des axes locaux aux noeuds c CALL CQ8LOC(XE,NBNN,MINTE1.SHPTOT,WORK(21),IRR) c c boucle sur les points de gauss c DO 3042 IGAU=1,NBPTEL c c calcul de la matrice b c E3=DZEGAU(IGAU) CALL BCOQ8E(IGAU,XE,NBNN,WORK(1),WORK(11),BGENE,DJAC, 1 E3,SHPTOT,WORK(21),IRR) c IF (IRR.EQ.0) THEN INTERR(1)=IB CALL ERREUR(241) GOTO 9941 ELSE IF (IRR.EQ.-1) THEN INTERR(1)=IB CALL ERREUR(240) GOTO 9941 ENDIF c c on cherche les coeff des mat de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN DO 9041 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9041 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHCOE(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF c c on calcule les contraintes pour le point de gauss c CALL DBST (BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS ) c c on remplit les contraintes c MPTVAL=IVASTR DO 6041 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XSTRS(ICOMP) 6041 CONTINUE c 3042 CONTINUE c 3041 CONTINUE IF (IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9941 CONTINUE SEGSUP,WRK2,WRK3 SEGDES MINTE1 GOTO 510 c____________________________________________________________________ c c element coq2 c____________________________________________________________________ c 44 CONTINUE NBNO=NBNN SEGINI WRK2 NDDD=NDEP IF (IFOUR.EQ.-3) NDDD=NDEP-3 DO 3044 IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO 5044 IGAU=1,NBNN DO 5044 ICOMP=1,NDDD MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 5044 CONTINUE IF (IFOUR.EQ.-3) THEN XDDL(IE)=UZDPG XDDL(IE+1)=RYDPG XDDL(IE+2)=RXDPG ENDIF c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c c on cherche les epaisseurs et les excentrements, c on les moyenne sur l'element. c EPAIST=0.D0 MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EPAIST=EPAIST+VELCHE(IGMN,IBMN) ENDDO EPAIST=EPAIST/NBPGAU ENDIF * EXCEN=0.D0 MELVAL=IVAL(2) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EXCEN=EXCEN+VELCHE(IGMN,IBMN) ENDDO EXCEN=EXCEN/NBPGAU ENDIF c c boucle sur les points de gauss c DO 4044 IGAU=1,NBPGAU c c appel a bcoq2 c CALL BCOQ2(BGENE,NSTRS,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU, . EXCEN,1.D0,IRR,XDPGE,YDPGE) c c gestion d'erreur c IF (IRR.EQ.1) THEN INTERR(1)=IB CALL ERREUR(255) GOTO 9944 ELSE IF (IRR.EQ.2) THEN INTERR(1)=IB CALL ERREUR(256) GOTO 9944 ENDIF c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOMU) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO 1044 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 1044 CONTINUE CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) ENDIF c c on va séparer l'appel à DBST en 3 parties : c - multiplication de B * DDL c - rajout éventuel de termes quadratiques c - multiplication des deformations par la matrice de Hooke c c CALL DBST(BGENE,DDHOMU,XDDL,LRE,NSTRS,XSTRS) c CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) IF(IREPS2.EQ.1) +call b2coq2(xstrs,nstrs,xddl,nbnn*ndep,xe,nbnn,QSIGAU,POIGAU,igau) call dxdefo(ddhomu,nstrs,xstrs) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO 9044 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 9044 CONTINUE 4044 CONTINUE 3044 CONTINUE c IF (IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9944 CONTINUE SEGSUP,WRK2 GOTO 510 c____________________________________________________________________ c c element coq4 c____________________________________________________________________ c 49 CONTINUE NBNO=NBNN SEGINI WRK2,WRK4 DO 3049 IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO 5049 IGAU=1,NBNN DO 5049 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 5049 CONTINUE c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c CALL CQ4LOC(XE,XEL,BPSS,IERT,1) c iert=1 nodi troppo vicini IF (IERT.EQ.1) THEN INTERR(1)=IB CALL ERREUR(323) GOTO 9949 ELSE IF (IERT.EQ.3) THEN IERT = 0 NOPLAN = 1 ELSE NOPLAN = 0 ENDIF CALL MATVEC(XDDL,XDDLOC,BPSS,8) c c on cherche les epaisseurs et les excentrements, c on les moyenne sur l'element. c MPTVAL=IVACAR EPAIST=0.D0 MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EPAIST=EPAIST+VELCHE(IGMN,IBMN) ENDDO EPAIST=EPAIST/NBPGAU ENDIF * EXCEN=0.D0 MELVAL=IVAL(2) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EXCEN=EXCEN+VELCHE(IGMN,IBMN) ENDDO EXCEN=EXCEN/NBPGAU ENDIF c c boucle sur les points de gauss c DO 4049 IGAU=1,NBPGAU c c appel a bcoq4 c if(cmate.eq.'ISOTROPE') then CALL BCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IERT,1) else CALL BCOQ4O(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IERT,1) endif c iert=1 jacobiano <= 0 IF (IERT.EQ.1) THEN INTERR(1)=IB CALL ERREUR(321) GOTO 9949 ENDIF c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOMU) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO 1049 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 1049 CONTINUE CALL DOHCIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) ENDIF c CALL DBST(BGENE,DDHOMU,XDDLOC,LRE,NSTRS,XSTRS) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO 9049 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 9049 CONTINUE 4049 CONTINUE 3049 CONTINUE c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9949 CONTINUE SEGSUP,WRK2,WRK4 GOTO 510 c____________________________________________________________________ c c element joint joi2 c____________________________________________________________________ c 85 CONTINUE NBNO=NBNN SEGINI WRK2,WRK4 c DO 3085 IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO 5085 IGAU=1,NBNN DO 5085 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 5085 CONTINUE c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) c c----------------------------------------------------------------- c je n'ai pas besoin de transformer les deplacements c dans le repere local car la matrice b est un operateur qui c s'applique sur une quantite globale, u, pour donner une c quantite locale, epsilon ; ceci, du fait de la presence c de la matrice teta dans l'expression de b. si cela est vrai, c alors il n'est pas necessaire d'appeler matvec. c il faudra simplement appeler dbst avec xddl et non pas avec c xddloc. c----------------------------------------------------------------- ccccccccc call matvec(xddl,xddloc,bpss,8) c c boucle sur les points de gauss c DO 4085 IGAU=1,NBPGAU c c appel a bjo2 pour le calcul de b c CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, . BGENE,DJAC,IRRT) c irrt=1 jacobien <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) GOTO 9985 ENDIF c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO 1085 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 1085 CONTINUE CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF c CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO 9085 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 9085 CONTINUE 4085 CONTINUE 3085 CONTINUE c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9985 CONTINUE SEGSUP,WRK2,WRK4 GOTO 510 c____________________________________________________________________ c c element joint jgi2 c____________________________________________________________________ c 170 CONTINUE NBNO=NBNN SEGINI WRK2,WRK4 NDDD=NDEP IF (IFOUR.EQ.-3) NDDD=NDEP-3 EPAIST=0.D0 DO IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO IGAU=1,NBNN DO ICOMP=1,NDDD MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 ENDDO ENDDO IF (IFOUR.EQ.-3) THEN XDDL(IE)=UZDPG XDDL(IE+1)=RYDPG XDDL(IE+2)=RXDPG ENDIF c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) c c boucle sur les points de gauss c DO IGAU=1,NBPGAU c c on cherche l'epaisseur du joint c MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EPAIST=VELCHE(IGMN,IBMN) ENDIF c c appel a bjo2 pour le calcul de b c CcPPj CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, CcPPj. EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT) CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK, . EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT) c irrt=1 jacobien <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) GOTO 9970 ENDIF c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF ENDDO CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF c CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) ENDDO ENDDO ENDDO c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9970 CONTINUE SEGSUP,WRK2,WRK4 GOTO 510 c____________________________________________________________________ c c element joint jct3 Pour le moment en 2D cisaillement c____________________________________________________________________ c 168 CONTINUE NBNO=NBNN SEGINI WRK2,WRK4 IF(CMATE.NE.'ISOTROPE')THEN MPTVAL=IVAMAT IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN MELVAL=IVAL(4) ELSE MELVAL=IVAL(2) ENDIF NBGCOS=VELCHE(/1) ENDIF DO IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO IGAU=1,NBNN DO ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 ENDDO ENDDO c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) c c boucle sur les points de gauss c DO IGAU=1,NBPGAU c c appel a bjt3 pour le calcul de b c CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, . BGENE,DJAC,IRRT) c irrt=1 jacobien <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) GOTO 9968 ENDIF c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF ENDDO CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF c CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) ENDDO ENDDO ENDDO c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9968 CONTINUE SEGSUP,WRK2,WRK4 GOTO 510 c____________________________________________________________________ c c element de joint generalise jgt3 c____________________________________________________________________ c 171 CONTINUE NBNO=NBNN SEGINI WRK2,WRK4 IF(CMATE.NE.'ISOTROPE')THEN MPTVAL=IVAMAT IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN MELVAL=IVAL(4) ELSE MELVAL=IVAL(2) ENDIF NBGCOS=VELCHE(/1) ENDIF DO IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO IGAU=1,NBNN DO ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 ENDDO ENDDO c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) c c boucle sur les points de gauss c DO IGAU=1,NBPGAU c c on cherche l'epaissuer du joint c EPAIST=0.D0 MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EPAIST=VELCHE(IGMN,IBMN) ENDIF c c appel a bjt3 pour le calcul de b c CcPPj CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK, . EPAIST,BGENE,DJAC,IRRT) c irrt=1 jacobien <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) GOTO 9971 ENDIF c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF ENDDO CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF c CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) ENDDO ENDDO ENDDO c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9971 CONTINUE SEGSUP,WRK2,WRK4 GOTO 510 c____________________________________________________________________ c c element joint jgi4 Pour le moment en 2D cisaillement c____________________________________________________________________ c 169 CONTINUE NBNO=NBNN SEGINI WRK2,WRK4 IF(CMATE.NE.'ISOTROPE')THEN MPTVAL=IVAMAT IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN MELVAL=IVAL(4) ELSE MELVAL=IVAL(2) ENDIF NBGCOS=VELCHE(/1) ENDIF c DO IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO IGAU=1,NBNN DO ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 ENDDO ENDDO c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) c c boucle sur les points de gauss c DO IGAU=1,NBPGAU c c appel a bjo4 pour le calcul de b c CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT) c irrt=1 jacobien <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) GOTO 9969 ENDIF c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF ENDDO CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF c CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) ENDDO ENDDO ENDDO c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9969 CONTINUE SEGSUP,WRK2,WRK4 GOTO 510 c____________________________________________________________________ c c element joint jgi4 Pour le moment en 2D cisaillement c____________________________________________________________________ c 172 CONTINUE NBNO=NBNN SEGINI WRK2,WRK4 IF(CMATE.NE.'ISOTROPE')THEN MPTVAL=IVAMAT IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN MELVAL=IVAL(4) ELSE MELVAL=IVAL(2) ENDIF NBGCOS=VELCHE(/1) ENDIF c DO IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO IGAU=1,NBNN DO ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 ENDDO ENDDO c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) c c boucle sur les points de gauss c DO IGAU=1,NBPGAU c c on cherche l'epaissuer du joint c EPAIST=0.D0 MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EPAIST=VELCHE(IGMN,IBMN) ENDIF c c appel a bjo4 pour le calcul de b c CcPPj CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,IRRT) CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC, . IRRT) c irrt=1 jacobien <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) GOTO 9972 ENDIF c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF ENDDO CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF c CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) ENDDO ENDDO ENDDO c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9972 CONTINUE SEGSUP,WRK2,WRK4 GOTO 510 c____________________________________________________________________ c c element joint joi3 implementation sans test de planeite c et sans repere local c____________________________________________________________________ c 86 CONTINUE NBNO=NBNN SEGINI WRK2,WRK4 c DO 3086 IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO 5086 IGAU=1,NBNN DO 5086 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 5086 CONTINUE c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c c boucle sur les points de gauss c DO 4086 IGAU=1,NBPGAU c CALL JO3LOC(XE,SHPTOT,IGAU,NBNN,BPSS) c c appel a bjo3 pour le calcul de b c CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK, . BGENE,DJAC,IRRT) c irrt=1 jacobien <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) GOTO 9986 ENDIF c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO 1086 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 1086 CONTINUE CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF c CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO 9086 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 9086 CONTINUE 4086 CONTINUE 3086 CONTINUE c c impression d'un eventuel message d'erreur c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9986 CONTINUE SEGSUP,WRK2,WRK4 GOTO 510 c____________________________________________________________________ c c element joint jot3 c____________________________________________________________________ c 87 CONTINUE NBNO=NBNN SEGINI WRK2,WRK4 IF(CMATE.NE.'ISOTROPE')THEN MPTVAL=IVAMAT IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN MELVAL=IVAL(4) ELSE MELVAL=IVAL(2) ENDIF NBGCOS=VELCHE(/1) ENDIF c DO 3087 IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO 5087 IGAU=1,NBNN DO 5087 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 5087 CONTINUE c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) c c----------------------------------------------------------------- c je ne pense pas avoir besoin de transformer les deplacements c dans le repere local car la matrice b est un operateur qui c s'applique sur une quantite globale, u, pour donner une c quantite locale, epsilon ; ceci, du fait de la presence c de la matrice teta dans l'expression de b. si cela est vrai, c alors il n'est pas necessaire d'appeler matvec. c il faudra simplement appeler dbst avec xddl et non pas avec c xddloc. c----------------------------------------------------------------- ccccccccc call matvec(xddl,xddloc,bpss,8) c c boucle sur les points de gauss c DO 4087 IGAU=1,NBPGAU c c appel a bjt3 pour le calcul de b c CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, . BGENE,DJAC,IRRT) c irrt=1 jacobien <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) GOTO 9987 ENDIF c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO 1087 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 1087 CONTINUE CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF c CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO 9087 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 9087 CONTINUE 4087 CONTINUE 3087 CONTINUE c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9987 CONTINUE SEGSUP,WRK2,WRK4 GOTO 510 c____________________________________________________________________ c c element joint joi4 c____________________________________________________________________ c 88 CONTINUE NBNO=NBNN SEGINI WRK2,WRK4 IF(CMATE.NE.'ISOTROPE')THEN MPTVAL=IVAMAT IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN MELVAL=IVAL(4) ELSE MELVAL=IVAL(2) ENDIF NBGCOS=VELCHE(/1) ENDIF DO 3088 IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO 5088 IGAU=1,NBNN DO 5088 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 5088 CONTINUE c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) c c----------------------------------------------------------------- c je ne pense pas avoir besoin de transformer les deplacements c dans le repere local car la matrice b est un operateur qui c s'applique sur une quantite globale, u, pour donner une c quantite locale, epsilon ; ceci, du fait de la presence c de la matrice teta dans l'expression de b. si cela est vrai, c alors il n'est pas necessaire d'appeler matvec. c il faudra simplement appeler dbst avec xddl et non pas avec c xddloc. c----------------------------------------------------------------- ccccccccc call matvec(xddl,xddloc,bpss,8) c c boucle sur les points de gauss c DO 4088 IGAU=1,NBPGAU c c appel a bjo4 pour le calcul de b c CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT) c irrt=1 jacobien <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) GOTO 9988 ENDIF c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO 1088 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 1088 CONTINUE CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF c CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO 9088 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 9088 CONTINUE 4088 CONTINUE 3088 CONTINUE c c impression d'un eventuel message d'erreur IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9988 CONTINUE SEGSUP,WRK2,WRK4 GOTO 510 c____________________________________________________________________ c c element dst c____________________________________________________________________ c 93 CONTINUE NBNO=NBNN SEGINI WRK2,WRK3,WRK4 IF(CMATE.NE.'ISOTROPE')THEN MPTVAL=IVAMAT IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN MELVAL=IVAL(7) ELSE MELVAL=IVAL(2) ENDIF NBGCOS=VELCHE(/1) ENDIF c DO 3093 IB=1,NBELEM c c on cherche les deplacements c MPTVAL=IVADEP IE=1 DO 4093 IGAU=1,NBNN DO 4093 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4093 CONTINUE c c on cherche les coordonnees des noeuds de l'element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL VPAST(XE,BPSS) c bpss stocke la matrice de passage CALL VCORLC (XE,XEL,BPSS) CALL MATVEC(XDDL,XDDLOC,BPSS,6) c c on cherche les epaiseurs et on les moyenne, c les excentrements et on les moyenne. c EPAIST=0.D0 MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EPAIST=EPAIST+VELCHE(IGMN,IBMN) ENDDO EPAIST=EPAIST/NBPGAU ENDIF * EXCEN=0.D0 MELVAL=IVAL(2) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EXCEN=EXCEN+VELCHE(IGMN,IBMN) ENDDO EXCEN=EXCEN/NBPGAU ENDIF c c boucle sur les points de gauss c DO 5093 IGAU=1,NBPTEL * * dans le cas des matériaux orthotropes, les déformations sont d'abord * calculées dans le repère d'orthotropie (les formules utilisées par les * routines rcdst et bmfdst ne sont valables que dans ce repère); elles * sont ensuite exprimées dans le repère local de l'élément. * IF(IMAT.EQ.2)THEN IF(CMATE.NE.'ISOTROPE')THEN IF(IGAU.LE.NBGCOS)THEN MPTVAL=IVAMAT MELVAL=IVAL(2) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) COSA=VELCHE(IGMN,IBMN) MELVAL=IVAL(3) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) SINA=VELCHE(IGMN,IBMN) ENDIF ENDIF ENDIF c c on cherche la matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOMU) SEGDES MLREEL IF(CMATE.EQ.'ORTHOTRO') + CALL CHGREP1(COSA,SINA,DDHOMU,LHOOK) ENDIF ELSE IF (IMAT.EQ.1) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN DO 9193 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9193 CONTINUE CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD) ENDIF CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) ENDIF call zero(bgene,nstrs,lre) IF(CMATE.NE.'ISOTROPE')THEN IF(IGAU.LE.NBGCOS)THEN IF(IMAT.EQ.1) THEN COSA=VALMAT(7) SINA=VALMAT(8) ENDIF DO 1393 INO=1,NBNN XX=COSA*XEL(1,INO)+SINA*XEL(2,INO) YY=(-SINA)*XEL(1,INO)+COSA*XEL(2,INO) XE(1,INO)=XX XE(2,INO)=YY 1393 CONTINUE ENDIF c c termes de la matrice de rigidite relatifs c aux cisaillements transverses c CALL RCDST(XE,NSTRS,LRE,DDHOMU, 1 WORK(1),WORK(10),WORK(19),REL,BGENE,1) c c termes de la matrice b relatifs aux effets c de membrane et de flexion c CALL BMFDST(IGAU,XE,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK, 1 WORK(1),WORK(10),WORK(19),BGENE,DUM) * CALL ROTB(BGENE,NSTRS,COSA,SINA) ELSE c c termes de la matrice b relatifs aux cisaillements transverses c CALL RCDST(XEL,NSTRS,LRE,DDHOMU, 1 WORK(1),WORK(10),WORK(19),REL,BGENE,1) c c termes de la matrice b relatifs aux effets c de membrane et de flexion c CALL BMFDST(IGAU,XEL,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK, 1 WORK(1),WORK(10),WORK(19),BGENE,DJAC) ENDIF * * on modifie la matrice b en cas d'excentrement * IF (EXCEN.NE.0.D0) THEN DO 1593 IJL=1,3 DO 1593 IJC=1,LRE BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC) 1593 CONTINUE ENDIF * CALL DBST(BGENE,DDHOMU,XDDLOC,LRE,NSTRS,XSTRS) c c calcul des eps 2 c IF(IREPS2.EQ.1)THEN IF(CMATE.EQ.'ORTHOTRO')THEN CALL DBDST2(XE,DDHOMU,XDDLOC,IGAU,BGENE,CMATE, 1 COSA,SINA,XSTRS) ELSE CALL DBDST2(XEL,DDHOMU,XDDLOC,IGAU,BGENE,CMATE, 1 COSA,SINA,XSTRS) ENDIF ENDIF * * changement de repere: ortho -> local * IF(CMATE.EQ.'ORTHOTRO') 1 CALL CHGREP2(COSA,SINA,XSTRS,0,1) c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO 9093 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XSTRS(ICOMP) 9093 CONTINUE 5093 CONTINUE 3093 CONTINUE c IF (IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9993 CONTINUE SEGSUP,WRK2,WRK3,WRK4 GOTO 510 c____________________________________________________________________ c____________________________________________________________________ 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(9:12)='SIGM' CALL ERREUR(86) * c- Fin du sous-programme 510 CONTINUE SEGSUP MVELCH,WRK1 RETURN END