C EPSI3 SOURCE AM 13/12/16 21:15:33 7825 SUBROUTINE EPSI3(IPMAIL,IVADEP,IVACAR,NELMAT,NBGMAT,IVECT, & IVAMAT,LHOOK,IMAT,MATE,CMATE,NMATT,NSTRS,MFR,IPMINT, & NCARR,NDEP,NBPGAU,NBPTEL,MELE,LRE,LW,IREPS2,IVAEPS, & IPMIN1,UZDPG,RYDPG,RXDPG,NPINT,IIPDPG) *---------------------------------------------------------------------* * * CALCUL DES DEFORMATIONS * * * * poutres,tuyaux,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 * 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 * * dans le cas des elements de coque integres * * * SORTIES : * * ________ * * * * IVAEPS pointeur sur un segment MPTVAL contenant les * * les melvals de déformations * * *---------------------------------------------------------------------* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMCHPOI -INC SMELEME -INC SMCOORD -INC SMMODEL -INC SMINTE -INC SMLREEL C SEGMENT WRK1 REAL*8 DDHOOK(NSTRS,NSTRS) ,XDDL(LRE) ,XSTRS(NSTRS) REAL*8 XE(3,NBBB),DDHOMU(NSTRS,NSTRS) 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 wrk7 real*8 out(30),propel(45),wk7d(1),wk7rel(1) endsegment C SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT C SEGMENT MPTVAL INTEGER IPOS(NS),NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * SEGMENT,MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT C CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM PARAMETER (NINF=3) INTEGER INFOS(NINF) C C INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT C DE LA SECTION EN DEFO PLANE GENERALISEE C * initialisation pour l'optimiseur MELVAL=0 IF (IFOUR.EQ.-3)THEN IP=IIPDPG C* 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) * NHRM=NIFOUR * MINTE=IPMINT NBBB=NBNN 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,27,99,99,99,99,99,99,99,99,99,99,99, 2 41,27,99,44,99,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,27,85,86,87,88,99,99,99,99,93,99,99,99,99),MELE * GOTO(168,169,170,171,172),MELE-167 if(mele.eq.260) go to 260 * GOTO 99 c_______________________________________________________________________ c ELEMENT SHB8 c_______________________________________________________________________ 260 continue SEGINI WRK1,WRK7 DO 3260 IB=1,NBELEM 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 DEPLACEMENTS C IE=1 MPTVAL=IVADEP DO 4260 IGAU=1,NBNN DO 4260 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4260 CONTINUE propel(1)=1 propel(2)=0.3 propel(3)=ireps2 call shb8(11,xe,wk7d,propel,xddl,wk7rel,out) C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS IE=1 DO 7260 IGAU=1,NBPTEL DO 7260 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=out(IE) IE=IE+1 7260 CONTINUE C 3260 CONTINUE SEGSUP WRK1,WRK7 GOTO 510 C C_______________________________________________________________________ C C ELEMENTS COQ3 POUTRE ET TUYAU ET POUTRE TIMOSCHENKO C_______________________________________________________________________ C 27 CONTINUE SEGINI WRK1,WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3027 IB=1,NBELEM 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 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 IF(MELE.EQ.29.OR.MELE.EQ.42.OR.MELE.EQ.84) GO TO 5029 C CAS DES COQ3 C C ON MET LA MATRICE DE HOOKE A L IDENTITE C CALL HOOKID(DDHOOK,NSTRS) CALL COQ3ST(XE,XDDL,XSTRS,DDHOOK) C IF(IREPS2.EQ.1) 1 CALL DBCO32(XE,DDHOOK,XDDL,WORK,XSTRS) C MPTVAL=IVAEPS DO 6027 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB,VELCHE(/2)) VELCHE(1,IBMN)=XSTRS(ICOMP) 6027 CONTINUE C GOTO 3027 C C CAS DES POUTRES ET DES TUYAUX C ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES DANS WORK C 5029 CONTINUE C C pour les poutres et tuyaux on cherche le module d'young et nu si C section reduite If( mele.eq.29.or.mele.eq.42) then mptval = ivamat segact mptval do itc=1,2 melval=ival(itc) IGMN=MIN(IGAU,VELCHE(/1)) ibmn= MIN(IB,VELCHE(/2)) xaa=VELCHE(IGMN,IBMN) if(itc.eq.1) then youtc=xaa else xnutc=xaa endif enddo endif C C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB C CALL ZERO(WORK,NCARR,1) DO 4029 IGAU=1,NBNN MPTVAL=IVACAR DO 6029 IC=1,NCARR IF(IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) IF(IGMN.GT.0.AND.IBMN.GT.0) THEN WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) ELSE WORK(IC)=0. ENDIF ELSE WORK(IC)=0. ENDIF IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 6029 CONTINUE 4029 CONTINUE C C CAS OU ON A LU LE MOT VECTEUR C IF (IFOUR.EQ.2) THEN C IF (IVECT.EQ.1) THEN IF (IVAL(NCARR).NE.0) THEN MELVAL=IVAL(NCARR) IBMN=MIN(IB,IELCHE(/2)) IP=IELCHE(1,IBMN) IREF=(IP-1)*(IDIM+1) DO 6129 IC=1,IDIM WORK(NCARR+IC-1)=XCOOR(IREF+IC) 6129 CONTINUE ELSE DO 6229 IC=1,IDIM WORK(NCARR+IC-1)=0.D0 6229 CONTINUE ENDIF ENDIF C ENDIF C C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE C EQUIVALENTE IF(MELE.EQ.42) THEN CISA=WORK(4) VX=WORK(5) VY=WORK(6) VZ=WORK(7) CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2) ENDIF C C ON CALCULE LES DEFORMATIONS C IF(MELE.EQ.84) THEN C IF(CMATE.EQ.'SECTION') THEN IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIMEP2(XE,XDDL,WORK(12),WORK(25),IREPS2) ELSE CALL TIMEPS(XE,XDDL,WORK(1),WORK(12),WORK(25),IREPS2) ENDIF ELSE C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIMEP2(XE,XDDL,WORK(12),WORK(25),IREPS2) C ELSE CALL TIMEPS(XE,XDDL,WORK(7),WORK(12),WORK(25),IREPS2) ENDIF ENDIF ELSE C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL POUEP2(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2 $ ,youtc,xnutc) ELSE C CALL POUEPS(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2 $ , youtc,xnutc) ENDIF ENDIF C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C ID=12 C MPTVAL=IVAEPS DO 7029 IGAU=1,NBPTEL DO 7029 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=WORK(ID) ID=ID+1 7029 CONTINUE C 3027 CONTINUE SEGSUP WRK1,WRK3 GOTO 510 C_______________________________________________________________________ C C ELEMENT DKT C_______________________________________________________________________ C 28 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2,WRK4 IF(NPINT.NE.0)THEN NSTRS1=6 SEGINI WRK5 ENDIF DO 3028 IB=1,NBELEM 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 DEPLACEMENTS C IE=1 DO 4028 IGAU=1,NBNN MPTVAL=IVADEP 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 L EPAISSEUR ET L EXCENTREMENT C MPTVAL=IVACAR IF (IVAL(1).NE.0) THEN MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) EPAIST=VELCHE(1,IBMN) ELSE EPAIST=0.D0 ENDIF C IF (IVAL(2).NE.0) THEN MELVAL=IVAL(2) IBMN=MIN(IB,VELCHE(/2)) EXCEN=VELCHE(1,IBMN) ELSE EXCEN=0.D0 ENDIF C CALL VPAST(XE,BPSS) C BPSS STOCKE LA MATRICE DE PASSAGE CALL VCORLC (XE,XEL,BPSS) CALL MATVEC(XDDL,XDDLOC,BPSS,6) 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 * IF (EXCEN.NE.0.) 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 * CALL BST(BGENE,XDDLOC,LRE,NSTRS,XSTRS) C C CALCUL DES EPS 2 C IF(IREPS2.EQ.1) 1 CALL BDKT2(XEL,XDDLOC,IGAU,BGENE,XSTRS) C C RMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS DO 9028 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,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 * IF (EXCEN.NE.0.) 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 CALL BST(BGENE,XDDLOC,LRE,NSTRS1,XSTRS1) C C CALCUL DES EPS 2 C IF(IREPS2.EQ.1) 1 CALL BDKT2(XEL,XDDLOC,IGAU,BGENE,XSTRS1) 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 DEFORMATIONS C MPTVAL=IVAEPS DO 9001 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU1,IBMN)=XSTRS(ICOMP) 9001 CONTINUE C 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 SEGSUP WRK1,WRK2,WRK4 IF(NPINT.NE.0) SEGSUP WRK5 * GOTO 510 C_______________________________________________________________________ C C ELEMENTS COQ8 ET COQ6 C_______________________________________________________________________ C 41 CONTINUE SEGINI WRK1,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 COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C ON CHERCHE LES DEPLACEMENTS C IE=1 DO 4041 IGAU=1,NBNN MPTVAL=IVADEP 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 EPAISSEURS ET LES EXCENTREMENTS, C ON LES MOYENNE SUR L'ELEMENT. C MPTVAL=IVACAR MELVAL=IVAL(1) EPAIST=0.D0 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 C MELVAL=IVAL(2) EXCEN=0.D0 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 ON CALCULE LES DEFORMATIONS C CALL COQ8EP(XE,NBNN,NBPGAU,LRE,NSTRS,EPAIST,EXCEN, 1 DZEGAU,SHPTOT,MINTE1.SHPTOT,XDDL,WORK,IRR) C C ON REMPLIT LES DEFORMATIONS C MPTVAL=IVAEPS IE=1 DO 6041 IGAU=1,NBPGAU DO 6041 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=WORK(IE) IE=IE+1 6041 CONTINUE C 3041 CONTINUE SEGSUP WRK1,WRK3 GOTO 510 C_______________________________________________________________________ C C ELEMENT COQ2 C_______________________________________________________________________ C 44 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2 C NDDD=NDEP IF (IFOUR.EQ.-3) NDDD=NDEP-3 DO 3044 IB=1,NBELEM 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 DEPLACEMENTS C MPTVAL=IVADEP IE=1 DO 2044 IGAU=1,NBNN DO 2044 ICOMP=1,NDDD MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 2044 CONTINUE IF (IFOUR.EQ.-3) THEN XDDL(IE)=UZDPG XDDL(IE+1)=RYDPG XDDL(IE+2)=RXDPG ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C DO 4044 IGAU=1,NBPGAU MPTVAL=IVACAR IF (IVAL(2).NE.0) THEN MELVAL=IVAL(2) IBMN=MIN(IB,VELCHE(/2)) EXCEN=VELCHE(1,IBMN) ELSE EXCEN=0.D0 ENDIF 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 CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) IF(IREPS2.EQ.1) +call b2coq2(xstrs,nstrs,xddl,nbnn*ndep,xe,nbnn,QSIGAU,POIGAU,igau) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS 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 9944 CONTINUE SEGSUP WRK1,WRK2 GOTO 510 C_______________________________________________________________________ C C ELEMENT COQ4 C_______________________________________________________________________ C 49 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2,WRK4 C DO 3049 IB=1,NBELEM 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 END IF C C ON CHERCHE LES DEPLACEMENTS C IE=1 DO 2049 IGAU=1,NBNN MPTVAL=IVADEP DO 2049 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 2049 CONTINUE CALL MATVEC(XDDL,XDDLOC,BPSS,8) C C BOUCLE SUR LES POINTS DE GAUSS 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 MELVAL=IVAL(2) IF (MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) EXCEN=VELCHE(1,IBMN) ELSE EXCEN=0.D0 ENDIF C DO 4049 IGAU=1,NBPGAU 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 CALL BST(BGENE,XDDLOC,LRE,NSTRS,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS 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 9949 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C_______________________________________________________________________ C C ELEMENT JOINT (JOI2) C_______________________________________________________________________ C 85 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2,WRK4 C DO 3085 IB=1,NBELEM 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 ON CHERCHE LES DEPLACEMENTS C MPTVAL=IVADEP IE=1 DO 2085 IGAU=1,NBNN DO 2085 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 2085 CONTINUE C C BOUCLE SUR LES POINTS DE GAUSS C DO 4085 IGAU=1,NBPGAU C CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, . BGENE,DJAC,IRRT) C IRRT.NE.0 JACOBIEN <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) GOTO 9985 ENDIF C CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS 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 9985 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C_______________________________________________________________________ C C ELEMENT JOINT (JGI2) C_______________________________________________________________________ C 170 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2,WRK4 C NDDD=NDEP IF (IFOUR.EQ.-3) NDDD=NDEP-3 C DO IB=1,NBELEM 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 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 BOUCLE SUR LES POINTS DE GAUSS C DO IGAU=1,NBPGAU C C ON CHERCHE L EPAISSEUR 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 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.NE.0 JACOBIEN <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) GOTO 9970 ENDIF C CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS 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 9970 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C_______________________________________________________________________ C C ELEMENT JOINT (JCT3) en 2D cisaillement C_______________________________________________________________________ C 168 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2,WRK4 C# MC 03/11/97 C MELVAL=??????? C IF (CMATE.NE.'ISOTROPE') THEN C MPTVAL=IVECT C MELVAL=IVAL(1) C NBGCOS=VELCHE(/1) C ENDIF C DO IB=1,NBELEM 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 ON CHERCHE LES DEPLACEMENTS C IE=1 MPTVAL=IVADEP 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 END DO END DO C C BOUCLE SUR LES POINTS DE GAUSS C DO IGAU=1,NBPGAU C CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, . BGENE,DJAC,IRRT) C IRRT.NE.0 JACOBIEN <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB GOTO 9968 ENDIF C CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) END DO END DO END DO C 9968 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C_______________________________________________________________________ C C ELEMENT JOINT (JGT3) GENERALISE C_______________________________________________________________________ C 171 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2,WRK4 C# MC 03/11/97 C MELVAL=??????? C IF (CMATE.NE.'ISOTROPE') THEN C MPTVAL=IVECT C MELVAL=IVAL(1) C NBGCOS=VELCHE(/1) C ENDIF C DO IB=1,NBELEM 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 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 END DO END DO C C BOUCLE SUR LES POINTS DE GAUSS C DO IGAU=1,NBPGAU C C ON CHERCHE L'EPAISSEUR 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 ON CALCULE 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.NE.0 JACOBIEN <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) GOTO 9971 ENDIF C CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) END DO END DO END DO C 9971 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C_______________________________________________________________________ C C ELEMENT JOINT (JCI4) en 2D cisaillement C_______________________________________________________________________ C 169 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2,WRK4 C# MC 03/11/97 C MELVAL=??????? C IF (CMATE.NE.'ISOTROPE') THEN C MPTVAL=IVECT C MELVAL=IVAL(1) C NBGCOS=VELCHE(/1) C ENDIF C DO IB=1,NBELEM 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 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 BOUCLE SUR LES POINTS DE GAUSS C DO IGAU=1,NBPGAU C CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT) C IRRT.NE.0 JACOBIEN <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) GOTO 9969 ENDIF C CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS 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 9969 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C_______________________________________________________________________ C C ELEMENT JOINT (JGI4) GENERALISE C_______________________________________________________________________ C 172 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2,WRK4 C# MC 03/11/97 C MELVAL=??????? C IF (CMATE.NE.'ISOTROPE') THEN C MPTVAL=IVECT C MELVAL=IVAL(1) C NBGCOS=VELCHE(/1) C ENDIF C DO IB=1,NBELEM 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 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 BOUCLE SUR LES POINTS DE GAUSS C DO IGAU=1,NBPGAU C C ON CHERCHE L'EPAISSEUR 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 CcPPj CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST, CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST, > BGENE,DJAC,IRRT) C IRRT.NE.0 JACOBIEN <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) GOTO 9972 ENDIF C CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS 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 9972 CONTINUE SEGSUP WRK1,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 WRK1,WRK2,WRK4 C DO 3086 IB=1,NBELEM 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 DEPLACEMENTS C MPTVAL=IVADEP IE=1 DO 2086 IGAU=1,NBNN DO 2086 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 2086 CONTINUE C C BOUCLE SUR LES POINTS DE GAUSS C DO 4086 IGAU=1,NBPGAU C CALL JO3LOC(XE,SHPTOT,IGAU,NBNN,BPSS) C CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK, . BGENE,DJAC,IRRT) C IRRT.NE.0 JACOBIEN <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) GOTO 9986 ENDIF C CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS 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 MESSAGE D'ERREUR C 9986 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C_______________________________________________________________________ C C ELEMENT JOINT (JOT3) C_______________________________________________________________________ C 87 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2,WRK4 C# MC 03/11/97 C MELVAL=??????? C IF (CMATE.NE.'ISOTROPE') THEN C MPTVAL=IVECT C MELVAL=IVAL(1) C NBGCOS=VELCHE(/1) C ENDIF C DO 3087 IB=1,NBELEM 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 ON CHERCHE LES DEPLACEMENTS C MPTVAL=IVADEP IE=1 DO 2087 IGAU=1,NBNN DO 2087 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 2087 CONTINUE C C BOUCLE SUR LES POINTS DE GAUSS C DO 4087 IGAU=1,NBPGAU C CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, . BGENE,DJAC,IRRT) C IRRT.NE.0 JACOBIEN <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) GOTO 9987 ENDIF C CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS 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 9987 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C_______________________________________________________________________ C C ELEMENT JOINT (JOI4) C_______________________________________________________________________ C 88 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2,WRK4 C# MC 03/11/97 C MELVAL=??????? C IF (CMATE.NE.'ISOTROPE') THEN C MPTVAL=IVECT C MELVAL=IVAL(1) C NBGCOS=VELCHE(/1) C ENDIF C DO 3088 IB=1,NBELEM 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 ON CHERCHE LES DEPLACEMENTS C MPTVAL=IVADEP IE=1 DO 2088 IGAU=1,NBNN DO 2088 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 2088 CONTINUE C C BOUCLE SUR LES POINTS DE GAUSS C DO 4088 IGAU=1,NBPGAU C CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT) C IRRT.NE.0 JACOBIEN <= 0 IF (IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) GOTO 9988 ENDIF C CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS 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 9988 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C_______________________________________________________________________ C C ELEMENT DST C_______________________________________________________________________ C 93 CONTINUE NBNO=NBNN NV1=NMATT SEGINI WRK1,WRK2,WRK3,WRK4,MVELCH 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 IRTD = 1 DO 3093 IB=1,NBELEM 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 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 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 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 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. 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 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 IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD) 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.AND.CMATE.EQ.'ORTHOTRO')THEN COSA=VALMAT(7) SINA=VALMAT(8) ELSE 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 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.) 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 BST(BGENE,XDDLOC,LRE,NSTRS,XSTRS) C C CALCUL DES EPS 2 C IF(IREPS2.EQ.1)THEN IF(CMATE.EQ.'ORTHOTRO')THEN CALL BDST2(XE,XDDLOC,IGAU,BGENE,CMATE,COSA,SINA,XSTRS) ELSE CALL BDST2(XEL,XDDLOC,IGAU,BGENE,CMATE,COSA,SINA,XSTRS) ENDIF ENDIF * * CHANGEMENT DE REPERE: ORTHO -> LOCAL * IF(CMATE.EQ.'ORTHOTRO') 1 CALL CHGREP2(COSA,SINA,XSTRS,0,0) C C RMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS DO 9093 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 9093 CONTINUE 5093 CONTINUE 3093 CONTINUE C C ERREUR LE MATERIAU PAS ENCORE IMPLEMENTER POUR C LA FORMULATION MFR ET L OPTION IFOUR 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 WRK1,WRK2,WRK3,WRK4,MVELCH GOTO 510 C____________________________________________________________________ 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(9:12)='EPSI' CALL ERREUR(86) * 510 CONTINUE RETURN END