law111_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/.
C  
!||====================================================================
!||    law111_upd             ../starter/source/materials/mat/mat111/law111_upd.F
!||--- called by ------------------------------------------------------
!||    updmat                 ../starter/source/materials/updmat.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    arret                  ../starter/source/system/arret.F
!||    func_slope             ../starter/source/tools/curve/func_slope.F
!||--- uses       -----------------------------------------------------
!||    message_mod            ../starter/share/message_module/message_mod.F
!||    table_mod              ../starter/share/modules1/table_mod.F
!||====================================================================
      SUBROUTINE law111_upd(IOUT,TITR    ,MAT_ID,UPARAM,NFUNC,
     .                      IFUNC, FUNC_ID,NPC   ,PLD   ,PM,IPM)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE table_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-----------------------------------------------
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      CHARACTER(LEN=NCHARTITLE)  :: TITR
      INTEGER MAT_ID,IOUT, NFUNC
      INTEGER NPC(*), FUNC_ID(*), IPM(NPROPMI)
      my_real uparam(*),pld(*),pm(npropm)
      INTEGER, DIMENSION(NFUNC):: IFUNC
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER N,K,ITEST,II,JJ,NSTART,IC1,IC2,NOGD,NDATA,NMULA,IFC,ICRYPT,
     .        icheck,ncomp
      my_real e,nu,gs,rbulk,d,young,errtol,ave_slope,mu,mu_max,mu_min,dx,
     .   scalefac,stiffmin,stiffmax,stiffini,stfavg
      my_real , DIMENSION(:), ALLOCATABLE :: stress,stretch
C==================================================================== 
!       IDENTIFICATION
!====================================================================
       icrypt = 0    !
       nstart = 2
       errtol = fiveem3   
       ifc = ifunc(1)
       ic1 = npc(ifc)
       ic2 = npc(ifc + 1)
       scalefac =  uparam(3)
       nogd=(ic2-ic1)/2
       ndata=nogd   
C
C  !! check if the curve don't have (0,0) point.
C        
         icheck = 0
         ncomp  = 0
         DO jj = ic1,ic2 - 4,2
              IF (pld(jj) == zero .AND. pld(jj + 1) == zero )icheck = 1
              IF (pld(jj) <  zero ) ncomp = ncomp + 1
         ENDDO 
         IF (icheck == 0 ) THEN
                              ! Error message
                 CALL ancmsg(msgid=1896,
     .                           msgtype=msgerror,
     .                           anmode=aninfo,
     .                           i1=mat_id,
     .                           c1=titr,
     .                           i2=func_id(ifc)) ! Id_function
                   CALL arret(2)
         ENDIF               
!!         IF (NCOMP == 0 ) THEN   ! No curve definition in compression => warning
!!                 CALL ANCMSG(MSGID=1917,
!!     .                       MSGTYPE=MSGWARNING,
!!     .                       ANMODE=ANINFO,
!!     .                       I1=MAT_ID,
!!     .                       C1=TITR,
!!     .                       I2=FUNC_ID(IFC)) ! Id_function
!!         ENDIF               
c
       ALLOCATE (stretch(nogd))                              
       ALLOCATE (stress(nogd))                               
c
       ave_slope = zero
       jj=0                                                  
       stretch=zero                                          
       stress=zero                                           
       mu=zero                                               
       rbulk=zero                                            
       gs=zero                           
c    
       CALL func_slope(ifunc(1),scalefac,npc,pld,stiffmin,stiffmax,stiffini,stfavg) 
C                                                                                        
        nu  = uparam(1)                                             
        !!GS  = STIFFMAX  
        gs  = stiffini 
C        
        rbulk=two*gs*(one+nu)                                               
     .        /max(em30,three*(one-two*nu)) 
        uparam(4) = gs                                                  
        uparam(5) = rbulk
        uparam(6) = uparam(4)
        IF(ncomp == 0) uparam(7) = 1  
!!        UPARAM(6)=TWO*STIFFMIN*(ONE+NU)
!!     .        /MAX(EM30,THREE*(ONE-TWO*NU))
c       parameters    
        young  = two*gs*(one + nu)               
        pm(20) = young                      
        pm(21) = nu                         
        pm(22) = gs                         
        pm(24) = young/(one - nu**2)         
        pm(32) = rbulk                      
        pm(100) = rbulk  !PARMAT(1) 
C-----------
C     Formulation for solid elements time step computation.
        ipm(252)= 2
        pm(105) = two*gs/(rbulk + four_over_3*gs)        
C                          
        IF (icrypt == 0) THEN
          WRITE(iout,1000)
          WRITE(iout,1100)gs,rbulk
        ENDIF
c----------------
c     end of optimization loop
c----------------
      RETURN
c----------------
 1000 FORMAT
     & (//5x, ' PARAMETERS FOR HYPERELASTIC_MATERIAL LAW111 ' ,/,
     &    5x, ' --------------------------------------------------')
 1100 FORMAT(
C
     & 5x,'MARLOW LAW',/,
     & 5x,'INITIAL SHEAR MODULUS. . . . . . . . . . .=',1pg20.13/
     & 5x,'BULK MODULUS . . . . . . . . . . . . . . .=',1pg20.13//)
c-----------
      RETURN
      END