C JAUCAU SOURCE AM 18/06/06 21:15:01 9834 SUBROUTINE JAUCAU (NBNN,tab1,Ncoele,NBPTEL,SHPTOT,XE1,XE2, & SHPWRK,tab,MWRK6,LHOOK, & KCAS,mwrk5,LADIM,mele,iipdpg) implicit real*8(a-h,o-z) implicit integer (i-n) -INC PPARAM -INC CCOPTIO SEGMENT MWRK5 REAL*8 BGR(NGRA,LRE),BB(2,NGRA),gradi(ngra),R(ngra),u(ngra) REAL*8 TENS(9),tentra(9),xddls2(lre) ENDSEGMENT * SEGMENT MWRK6 INTEGER ITRES1(NBPTEL) REAL*8 PRODDI(NBPTEL,LHOO2),PRODDO(NBPTEL,LHOO2) REAL*8 DDHOOK(LHOOK,LHOOK),DDHOMU(LHOOK,LHOOK) REAL*8 VEC(LHOOK),VEC2(LHOOK) ENDSEGMENT * dimension xe1(3,*),xe2(3,*) dimension shpwrk(6,*),shptot(6,NBNN,*) dimension tab(nbptel,*),tab1(nbptel,*) DIMENSION IDD(3),RM(6,6),SM(6,6) C PARAMETER (RAC2 = 1.414213562373090 D0) C DATA IDD/2,3,1/ C xxzero=0.d0 if (kcas.eq.2) then xxr=2.0d0 uxr=0.5d0 else xxr=1.d0 uxr=1.D0 endif C C MISE A ZERO DES CONTRAINTES OU DES DEFORMATIONS C DO 50 IB=1,NCOELE DO 50 IA=1,NBPTEL TAB(IA,IB)=0.D0 50 CONTINUE DO i = 1, 9 TENS(i) = xxZero ENDDO ngra=gradi(/1) lre=xddls2(/1) NHRM=NIFOUR C Calcul de l'increment de deplacement ia=0 do iou=1,NBNN do iyu=1, idim ia=ia+1 xddls2(ia)= XE2(iyu,iou) - xe1(iyu,iou) enddo enddo C - MODES DE CALCUL EN DEFORMATIONS "PLANES" GENERALISEES IF (IDIM.EQ.3) THEN C RIEN FAIRE ! C CAS 2D : ELSE IF (IDIM.EQ.2) THEN CC CAS 2D PLAN DEFO GENE C Rq : "Deplacement" UZ du PTGENE est stocke dans XE2(3,1) (cf. PIOCAP) IF (IFOUR.EQ.-3) THEN IA = IA + 1 xddls2(ia)= XE2(3,1) ENDIF C CAS 1D : ELSE IF (IDIM.EQ.1) THEN CCC CAS 1D PLAN IF (IFOUR.GE.3 .AND. IFOUR.LE.11) THEN C Rq : "Deplacement" UY du PTGENE est stocke dans XE2(2,1) (cf. PIOCAP) IF (IFOUR.EQ.7 .OR. IFOUR.EQ.8 .OR. IFOUR.EQ.11) THEN IA = IA + 1 xddls2(ia)= XE2(2,1) ENDIF C Rq : "Deplacement" UZ du PTGENE est stocke dans XE2(3,1) (cf. PIOCAP) c* IF (IFOUR.EQ.9 .OR. IFOUR.EQ.10 .OR. IFOUR.EQ.11) THEN IF (IFOUR.GE.9) THEN IA = IA + 1 xddls2(ia)= XE2(3,1) ENDIF CCC CAS 1D AXIS C Rq : "Deplacement" UZ du PTGENE est stocke dans XE2(2,1) (cf. PIOCAP) ELSE IF (IFOUR.EQ.14) THEN IA = IA + 1 xddls2(ia)= XE2(2,1) ENDIF ENDIF C Boucle sur les points d'intergration de l'element : do 51 igau=1,nbptel C Calcul du gradient du deplacment CALL BGRMAS(iGau,mele,nbnn,LRE,IFOUR,NGRA,NHRM,XE1, & xXZero,SHPTOT,SHPWRK,BB,BGR,DJAC,IIPDPG) CALL BGRDEP(BGR,NGRA,XDDLs2,LRE,GRADI) C Calcul de F IF (LADIM.EQ.3) THEN gradi(1)=gradi(1)+1.D0 gradi(5)=gradi(5)+1.D0 gradi(9)=gradi(9)+1.D0 C* ELSE if (LADIM.EQ.2) then ELSE gradi(1)=gradi(1)+1.D0 gradi(4)=gradi(4)+1.D0 ENDIF CALL POLA2(gradi,R,U,LADIM) * GO TO (500,500,700),KCAS * * * KCAS=1 OU 2 CAS DES CONTRAINTES OU DES DEFORMATIONS * ---------------------------------------------------- * 500 CONTINUE * fait le rtens R.A.Rt on utilise u pour mettre Rt * et on met le tenseur dans le tableau tens * attention, vu le stockage R est en fait Rt if (LAdim.eq.2) then U(1)=r(1) u(2)=r(3) U(3)=R(2) u(4)=R(4) tens(1)=tab1(igau,1) tens(2)=tab1(igau,4)*uxr tens(3)=tens(2) tens(4)=tab1(igau,2) c* else if (LAdim.eq.3) then else U(1)=r(1) u(2)=r(4) U(3)=R(7) u(4)=R(2) u(5)=r(5) u(6)=r(8) u(7)=r(3) u(8)=r(6) u(9)=r(9) tens(1)=tab1(igau,1) tens(5)=tab1(igau,2) tens(9)=tab1(igau,3) IF (IFOUR.EQ.1.OR.IFOUR.EQ.2) THEN tens(2)=tab1(igau,4)*uxr tens(3)=tab1(igau,5)*uxr tens(4)=tens(2) tens(6)=tab1(igau,6)*uxr tens(7)=tens(3) tens(8)=tens(6) ELSE IF (IFOUR.LE.0) THEN c* ELSE IF (IFOUR.EQ.0.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3 c* & IFOUR.EQ.-1) THEN tens(2)=tab1(igau,4)*uxr * tens(3)=xxzero tens(4)=tens(2) * tens(6)=xxzero * tens(7)=tens(3) * tens(8)=tens(6) * tens(9)=tab1(igau,3)=xxzero pour IFOUR=-1 * Modes de calcul 1D c ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN * tens(2)=xxzero * tens(3)=xxzero * tens(4)=tens(2) * tens(6)=xxzero * tens(7)=tens(3) * tens(8)=tens(6) ELSE CALL ERREUR(19) RETURN ENDIF endif CALL MULMAT(tentra,tens,R,LADIM,LADIM,LADIM) CALL MULMAT(tens,U,Tentra,LADIM,LADIM,LADIM) if(ladim.eq.2) then tab(igau,1)=tens(1) tab(igau,2)=tens(4) tab(igau,4)=tens(2)*xxr tab(igau,3)=tab1(igau,3) else tab(igau,1)=tens(1) tab(igau,2)=tens(5) tab(igau,3)=tens(9) IF (IFOUR.EQ.1.OR.IFOUR.EQ.2) THEN tab(igau,4)=tens(2)*xxr tab(igau,5)=tens(3)*xxr tab(igau,6)=tens(6)*xxr ELSE IF (IFOUR.LE.0) THEN c* ELSE IF (IFOUR.EQ.0.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3 c* & IFOUR.EQ.-1) THEN tab(igau,4)=tens(2)*xxr * Modes de calcul 1D c* ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN ENDIF endif * GO TO 130 C C KCAS=3 CAS DE LA MATRICE DE HOOKE C ---------------------------------- C 700 CONTINUE C IJ=1 FACJ=1. DO 710 JJ=1,LHOOK IF(JJ.GT.3) FACJ=RAC2 DO 710 II=1,LHOOK IF(II.GT.3) THEN FACI=RAC2 ELSE FACI=1. ENDIF DDHOOK(II,JJ)=PRODDI(IGAU,IJ)*FACJ*FACI IJ=IJ+1 710 CONTINUE * IF(LADIM.EQ.2) THEN CALL ZERO(RM,6,6) DO I=1,LADIM IN=(I-1)*LADIM DO J=1,LADIM JJ =IN + J RM(I,J)=R(JJ)*R(JJ) ENDDO RM(I,4)=RAC2*R(2*I-1)*R(2*I) RM(4,I)=RAC2*R(I)*R(I+LADIM) ENDDO RM(3,3)=1. RM(4,4)=R(1)*R(4)+R(2)*R(3) ELSE IF (LADIM.EQ.3) THEN DO I=1,LADIM IN=(I-1)*LADIM IP=(IDD(I)-1)*LADIM DO J=1,LADIM JJ =IN + J J2 =IN + IDD(J) J3 =IP + J RM(I,J)=R(JJ)*R(JJ) RM(I,J+LADIM)=RAC2*R(JJ)*R(J2) RM(I+LADIM,J)=RAC2*R(JJ)*R(J3) RM(I+LADIM,J+LADIM)=R(JJ)*R(IDD(J)+IP)+R(IDD(J)+IN)*R(J3) ENDDO ENDDO ENDIF * DO I=1,LHOOK DO J=1,LHOOK SM(I,J)=0. DO K=1,LHOOK SM(I,J)=SM(I,J)+DDHOOK(I,K)*RM(K,J) ENDDO ENDDO ENDDO * DO I=1,LHOOK DO J=1,LHOOK DDHOMU(I,J)=0. DO K=1,LHOOK DDHOMU(I,J)=DDHOMU(I,J)+RM(K,I)*SM(K,J) ENDDO ENDDO ENDDO * IJ=1 FACJ=1. DO 780 JJ=1,LHOOK IF(JJ.GT.3) FACJ=RAC2 DO 780 II=1,LHOOK IF(II.GT.3) THEN FACI=RAC2 ELSE FACI=1. ENDIF PRODDO(IGAU,IJ)=DDHOMU(II,JJ)/FACJ/FACI IJ=IJ+1 780 CONTINUE * * 130 CONTINUE 51 CONTINUE RETURN END