law36_upd.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
!||====================================================================
!||    law36_upd              ../starter/source/materials/mat/mat036/law36_upd.F
!||--- called by ------------------------------------------------------
!||    updmat                 ../starter/source/materials/updmat.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    func_inters            ../starter/source/tools/curve/func_inters.F
!||--- uses       -----------------------------------------------------
!||    elbuftag_mod           ../starter/share/modules1/elbuftag_mod.F
!||    message_mod            ../starter/share/message_module/message_mod.F
!||    table_mod              ../starter/share/modules1/table_mod.F
!||====================================================================
      SUBROUTINE law36_upd(IOUT   ,TITR   ,MAT_ID ,NUPARAM,UPARAM ,
     .                     NFUNC  ,IFUNC  ,FUNC_ID,NPC    ,PLD    ,
     .                     MTAG   ,NFUNCT )
C----------------------------------------------- 
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE table_mod
      USE elbuftag_mod
      USE names_and_titles_mod , ONLY : nchartitle
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ,INTENT(IN) :: MAT_ID,IOUT,NUPARAM
      INTEGER ,INTENT(IN) :: NFUNC    ! number of functions defined in the law
      INTEGER ,INTENT(IN) :: NFUNCT   ! total number of functions in the system
      INTEGER, DIMENSION(NFUNC)  :: IFUNC
      INTEGER, DIMENSION(NFUNCT) :: FUNC_ID
      INTEGER NPC(*)
      my_real uparam(nuparam),pld(*)
      CHARACTER(LEN=NCHARTITLE)  :: TITR
      TYPE(mlaw_tag_),INTENT(INOUT)   :: MTAG
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I,J,IFE,IE,IX1,IX2,IY1,IY2,NRATE,IYLD,IFAIL,FUNC1,FUNC2
      my_real :: EPSMAX,EPSLAST,X1,X2,Y1,Y2,FAC1,FAC2,XINT,YINT
C==================================================================== 
c     Check if scale factor function of Young modulus is decreasing with plastic strain   
c    
      ife = ifunc(nfunc)                   
      IF (ife > 0) THEN 
        ie  = npc(ife)                                                       
        iy2 = npc(ife+1)                                                     
        DO i = ie+1,iy2-3,2                                                  
          IF (pld(i) < pld(i+2)) THEN                                       
             CALL ancmsg(msgid=975, msgtype=msgerror, anmode=aninfo,        
     .            i1 = func_id(nfunc),                                               
     .            c1 = titr   )                                               
             EXIT                                                           
          ENDIF                                                             
        ENDDO                                                                
      ENDIF                                      
c    
c     Check if static yield function decreases to zero (last point or negative slope)
c     In this case we introduce failure at the plastic strain corresponding to sig_yld=0
c  
      nrate  = nint(uparam(1))
      epsmax = uparam(2*nrate + 7)
      ifail  = nint(uparam(2*nrate + 27))
      iyld = ifunc(1)
      ix1  = npc(iyld+1) - 4                                     
      iy1  = npc(iyld+1) - 3                                     
      iy2  = npc(iyld+1) - 1                                     
      ix2  = npc(iyld+1) - 2
      x1 = pld(ix1)                                    
      x2 = pld(ix2)                                    
      y1 = pld(iy1)                                    
      y2 = pld(iy2)                                    
      IF (ix2 > zero .and. y2 == zero) THEN  ! last value of yield curve is 0
        epslast = x2
        epsmax  = uparam(7+2*nrate)
        IF (epslast < epsmax) uparam(2*nrate + 7 ) = epslast
        IF (ifail == 0)       uparam(2*nrate + 27) = 1    ! IFAIL
        uparam(2*nrate + 28) = 1    ! YLDCHECK
        mtag%G_DMG = 1
        mtag%L_DMG = 1        
      ELSE IF (y1 > y2) THEN                 ! yield function slope is negative 
        epslast = (x2*y1 - x1*y2) / (y1 - y2)
        IF (epslast < epsmax) uparam(2*nrate + 7 ) = epslast
        IF (ifail == 0)       uparam(2*nrate + 27) = 1    ! IFAIL
        uparam(2*nrate + 28) = 1    ! YLDCHECK
        mtag%G_DMG = 1
        mtag%L_DMG = 1        
      ENDIF                                      
c-----------------------------------------------------------------------    
c     Check if yield curves for different strain rates do not intersect
c-----------------------------------------------------------------------
      DO i = 1,nrate
        func1 = ifunc(i)
        fac1  = uparam(nrate + 6 + i)
        DO j = i+1,nrate
          func2 = ifunc(j)
          fac2  = uparam(nrate + 6 + j)
          IF (func1 > 0 .and. func2 > 0 .and. func1 /= func2) THEN
            CALL func_inters(titr,mat_id,func1 ,func2 ,fac1 ,fac2 ,
     .                 npc ,pld   ,xint ,yint )
c
            IF (xint > zero .and. yint > zero) THEN
              CALL ancmsg(msgid=2064, msgtype=msgwarning, anmode=aninfo,        
     .                    i1 = mat_id,                                               
     .                    i2 = func_id(func1),                                               
     .                    i3 = func_id(func2),                                               
     .                    c1 = titr   )
            END IF
          END IF
        END DO                                                      
      END DO
c--------------------------------------------------------
      RETURN
      END