Sources Esope | Cast3M

microi
C MICROI    SOURCE    CB215821  16/04/21    21:17:44     8920
      SUBROUTINE MICROI (WRK0,WRK1,NSTRS,NVARI,NMATT,
     &                                 ICARA,KERRE,MFR1,IFOURB)
*
*   modele d'endommagement microplan isotrope couple a la plasticite
*   C. La Borderie + S. Fichant Oct. 95
*   routines utilisees:
*   micro1: plasticite nadai
*            IDECAL=3 DANS LE CAS ISO IDECAL=8 DANS LE CAS ANISO
*   jacob3: diagonalisation:
*            attention jacob3 modifie la matrice a diagonaliser!!
*   prodt et prodt2
*   attention prodt2 ne fonctionne qu'avec la matrice des V. P. !!
*
      IMPLICIT INTEGER(I-N)
C      IMPLICIT REAL*8(A-H,O-Z)
      INTEGER NSTRS,NVARI,NMATT,ICARA,KERRE,MFR1,IFOURB
      INTEGER ISTRS,I,J
      REAL*8 YOUNG,XNU,EPSD0,BT,LAMB,DEUXMU,ALFA
      REAL*8 DOM,SIGAN(6),TRSIG,DEF33(3,3),EPSIPP(3),VECP(3,3)
      REAL*8 D1
      REAL*8 SIGPP(3),SIGPM(3),SIG33(3,3),SIG33P(3,3),SIG33M(3,3)
      REAL*8 LAMBDAP,LAMBDAM
      REAL*8 DSIGT(6)
      INTEGER IDECAL
*
 
-INC PPARAM
-INC CCOPTIO
*
      SEGMENT WRK0
       REAL*8 XMAT(NMATT)
      ENDSEGMENT
*
      SEGMENT WRK1
        REAL*8 DDHOOK(LHOOK,LHOOK),SIG0(NSTRS),DEPST(NSTRS)
        REAL*8 SIGF(NSTRS),VAR0(NVARI),VARF(NVARI)
        REAL*8 DEFP(NSTRS),XCAR(ICARA)
      ENDSEGMENT
      SEGMENT WRKK1
        REAL*8 DEFELA(NSTRS)
      ENDSEGMENT
*
*   on recupere les variable materielles
*
      YOUNG=XMAT(1)
      XNU=XMAT(2)
      EPSD0=XMAT(5)
      BT=XMAT(6)
      ALFA=XMAT(9)
      DEUXMU=YOUNG/(1.D0+XNU)
      LAMB=XNU*DEUXMU/(1.D0-2.D0*XNU)
*
*     recuperation des variables internes d'endommagement
*
      DOM=VAR0(3)
      SEGINI WRKK1
*
*     on ecoule plastiquement sur la contrainte effective
*
        IDECAL=3
        CALL MICRO1(WRK0,NMATT,WRK1,NSTRS,DSIGT,
     1                             NVARI,IDECAL,KERRE,.false.)
        IF (KERRE .NE. 0) THEN
           print*,'on n''a pas converge dans micro1'
        CALL MICRO1(WRK0,NMATT,WRK1,NSTRS,DSIGT,
     1                              NVARI,IDECAL,KERRE,.true.)
           SEGSUP WRKK1
           RETURN
        ENDIF
*
*     on ecoule en endommagement sur les deformations elastiques
*
*
*     calcul des deformations elastiques
*
         TRSIG=0.D0
*      print*,'-----sigf------'
*      print*,sigf(1),sigf(2),sigf(3)
         DO ISTRS=1,3
            TRSIG=TRSIG+SIGF(ISTRS)
         END DO
         DO ISTRS=1,3
           DEFELA(ISTRS)=( (1.D0+XNU)*SIGF(ISTRS)-XNU*TRSIG)/YOUNG
         END DO
*      print*,'-----defela------'
*      print*,defela(1),defela(2),defela(3)
         DO ISTRS=4,NSTRS
           DEFELA(ISTRS)= (1.D0+XNU)*SIGF(ISTRS)/YOUNG
         END DO
*
*     on met les deformations sous forme de matrice 3x3
*     pour calculer les valeurs propres
*
         CALL ENDOCA (DEFELA,DEF33,1)
*         print*,'deformations elastiques dans rpg(3x3)'
*         print*,def33
*      print*,'prodt defrdpe'
         CALL JACOB3 (DEF33,3,EPSIPP,VECP)
*         print*,'deformations principales'
*         print*,(epsipp(i),i=1,3)
*
*     on calcule l'endommagement resultant
*
*         print*,'BT=',BT,'EPSD0=',EPSD0,'EPSIPP(1)',EPSIPP(1)
         IF (EPSIPP(1) .GT. EPSD0) THEN
           D1=1.D0-EPSD0/EPSIPP(1)*EXP(BT*( EPSD0 - EPSIPP(1)))
         ELSE
           D1=0.D0
         END IF
*         PRINT*,'D1=',D1
*
*
*     et on en l'endommagement final
*
         IF(d1.gt.dom)then
            dom=d1
         endif
*         print*,'DOM=',DOM
*
*     on separe les contraintes effectives en + et - dans rpsigma
*
         CALL ENDOCA (SIGF,SIG33,1)
         CALL JACOB3 (SIG33,3,SIGPP,VECP)
*         print*,'contraintes ppales'
*         print*,sigpp
         DO I=1,3
           IF (SIGPP(I) .LT. 0.D0)THEN
              SIGPM(I)=SIGPP(I)
              SIGPP(I)=0.D0
           ELSE
              SIGPM(I)=0.D0
           END IF
         END DO
         CALL PRODT2(SIG33P,SIGPP,VECP,3)
         CALL PRODT2(SIG33M,SIGPM,VECP,3)
*         print*,'contraintes dans rpg'
*         print*,sig33p
*         print*,sig33m
*
       LAMBDAP=1.D0-DOM
       LAMBDAM=1.D0-DOM**ALFA
       SIG33(1,1)=LAMBDAP*SIG33P(1,1)+LAMBDAM*SIG33M(1,1)
       SIG33(1,2)=LAMBDAP*SIG33P(1,2)+LAMBDAM*SIG33M(1,2)
       SIG33(1,3)=LAMBDAP*SIG33P(1,3)+LAMBDAM*SIG33M(1,3)
       SIG33(2,1)=SIG33(1,2)
       SIG33(2,2)=LAMBDAP*SIG33P(2,2)+LAMBDAM*SIG33M(2,2)
       SIG33(2,3)=LAMBDAP*SIG33P(2,3)+LAMBDAM*SIG33M(2,3)
       SIG33(3,1)=SIG33(1,3)
       SIG33(3,2)=SIG33(2,3)
       SIG33(3,3)=LAMBDAP*SIG33P(3,3)+LAMBDAM*SIG33M(3,3)
*       print*,'contraintes dans RPD'
*       print*,sig33p
*       print*,'sig33p(1,2)',sig33p(1,2)
*      print*,'dsigt',dsigt(1),dsigt(2),dsigt(3)
*      print*,'dsigt',dsigt(4),dsigt(5),dsigt(6)
*      print*,'sigf',sigf(1),sigf(2),sigf(3)
*      print*,'sigf',sigf(4),sigf(5),sigf(6)
*
 
*     on rend les contraintes et les variables internes finales
*
      SIGAN(1)=SIGF(1)-SIG33(1,1)
      SIGF(1)=SIG33(1,1)
      VARF(3)=MAX (DOM,0.d0)
      SIGAN(2)=SIGF(2)-SIG33(2,2)
      SIGF(2)=SIG33(2,2)
      SIGAN(3)=SIGF(3)-SIG33(3,3)
      SIGF(3)=SIG33(3,3)
      SIGAN(4)=SIGF(4)-SIG33(1,2)
      SIGF(4)=SIG33(1,2)
      IF(IFOUR.GE.1.OR.IFOUR.LE.-3) THEN
        SIGAN(5)=SIGF(5)-SIG33(1,3)
        SIGF(5)=SIG33(1,3)
        SIGAN(6)=SIGF(6)-SIG33(2,3)
        SIGF(6)=SIG33(2,3)
      ELSE
        SIGAN(5)=0.D0
        SIGAN(6)=0.D0
      END IF
      DO ISTRS=1,6
         VARF(ISTRS+3)=SIGAN(ISTRS)
      END DO
*      print*,'sigf',sigf(1),sigf(2),sigf(3)
*      print*,'sigf',sigf(4),sigf(5),sigf(6)
*      print*,'sigan',sigan(1),sigan(2),sigan(3)
*      print*,'sigan',sigan(4),sigan(5),sigan(6)
      SEGSUP WRKK1
      RETURN
      END