Numérotation des lignes :

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 CC     MISE A ZERO DES CONTRAINTES OU DES DEFORMATIONSC      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      enddoC - MODES DE CALCUL EN DEFORMATIONS "PLANES" GENERALISEES      IF (IDIM.EQ.3) THENC         RIEN FAIRE !C CAS 2D :      ELSE IF (IDIM.EQ.2) THENCC CAS 2D PLAN DEFO GENEC 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)        ENDIFC CAS 1D :      ELSE IF (IDIM.EQ.1) THENCCC CAS 1D PLAN        IF (IFOUR.GE.3 .AND. IFOUR.LE.11) THENC 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)          ENDIFC 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)          ENDIFCCC CAS 1D AXISC 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.D0C*      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) THENc*        ELSE IF (IFOUR.EQ.0.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3c*   &             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 1Dc         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) THENc*        ELSE IF (IFOUR.EQ.0.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3c*   &             IFOUR.EQ.-1) THEN            tab(igau,4)=tens(2)*xxr* Modes de calcul 1Dc*        ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN          ENDIF        endif*        GO TO 130 CC         KCAS=3  CAS DE LA MATRICE DE HOOKEC         ----------------------------------C  700   CONTINUEC      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

© Cast3M 2003 - Tous droits réservés.
Mentions légales