law88__upd_8F_source.html

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/.

!||====================================================================

!||    law88_upd              ../starter/source/materials/mat/mat088/law88_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_inters            ../starter/source/tools/curve/func_inters.F

!||    func_inters_c          ../starter/source/tools/curve/func_inters.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 law88_upd(IOUT   ,TITR   ,UPARAM ,NPC    ,PLD    ,

     .                     NFUNC  ,IFUNC  ,MAT_ID ,FUNC_ID,PM     ,

     .                     NFUNCT )

      USE message_mod

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

      INTEGER ,INTENT(IN) :: NFUNC

      INTEGER ,INTENT(IN) :: NFUNCT

      INTEGER NPC(*), FUNC_ID(NFUNCT),IFUNC(NFUNC)

      my_real uparam(*),pld(*)

      my_real , DIMENSION(NPROPM), INTENT(INOUT) :: pm

C-----------------------------------------------

C   L o c a l   V a r i a b l e s

C-----------------------------------------------

      INTEGER I,J,K,FUNC,FUND,PN,IOK,NL,IUNL_FOR,ICASE,NV,

     .  IC1,IC2,NOGD,II,JJ,ICHECK,ITENS

      my_real kc,kt,kfc,kft,gmax,deri,stiff,stiffmin,stiffini,

     .  stiffmax,stiffavg,xint1,yint1,xint2,yint2,fac,fac1,fac2,

     .  dx,dy, xinc,yinc,xint,yint

      my_real

     .     emax, emin,eini,scalefac,e0,ec_max,nu,gs

      my_real , DIMENSION(:), ALLOCATABLE :: stress,stretch

C=======================================================================

C----------------------------

       DO j = 1, nfunc

         k = ifunc(j)

         ic1  =  npc(k)

         ic2  =  npc(k+1)

         nogd =  (ic2-ic1)/2

         ALLOCATE (stretch(nogd), stress(nogd))

         jj = 0

         icheck = 0

         DO ii = ic1,ic2-2,2

              jj=jj+1

              stretch(jj) = pld(ii) + one

              stress(jj)  = pld(ii + 1)

                IF(pld(ii) <=  - one) THEN

                  CALL ancmsg(msgid=3085,

     .                         msgtype=msgwarning,

     .                         anmode=aninfo,

     .                         i1=mat_id,

     .                         c1=titr,

     .                         i2=func_id(k)) ! Id_function

              ENDIF

              !! check if the curve don't have (0,0) point.

              IF( pld(ii) == zero .AND. pld(ii + 1) == zero )icheck = 1

         ENDDO

         IF(icheck == 0 ) THEN

                              ! Error message

                 CALL ancmsg(msgid=1896,

     .                           msgtype=msgerror,

     .                           anmode=aninfo,

     .                           i1=mat_id,

     .                           c1=titr,

     .                           i2=func_id(k)) ! Id_function

                   CALL arret(2)

         ENDIF

C  check if the curve is monotonic

         DO jj =1,nogd - 1

           dx = stretch(jj + 1) - stretch(jj)

           dy = stress(jj  + 1) - stress(jj)

           IF(dx * dy < zero) THEN

             CALL ancmsg(msgid=1176,

     .              msgtype=msgerror,

     .              anmode=aninfo,

     .              i1=mat_id,

     .              c1=titr,

     .              i2=func_id(k))

           ENDIF

         ENDDO

          DEALLOCATE( stretch,stress)

        ENDDO ! NFUNC

c

c       Intersection - quasistatic curve and unloading curve but is not used

c

        nl = int(uparam(4))

        iunl_for = nint(uparam(5))

        itens    = nint(uparam(8))

        icase    = nint(uparam(9))

        nv = 9 + 2*nfunc

c

        xinc = zero

        yinc = zero

        xint = zero

        yint = zero

        func = ifunc(1)

        IF(nfunc > nl ) THEN

           fund = ifunc(nl + 1)

           fac1 = uparam(11  )

           fac2 = uparam(11 + 2*nl  )

C intersection pt of tension if existing

           uparam(nv + 1) = 0  ! not existing

           IF(func /= 0 .AND. fund /= 0) THEN

               CALL func_inters(titr   ,mat_id ,func   ,fund   ,fac1   ,

     .                            fac2   ,npc    ,pld    ,xint  ,yint  )

               uparam(nv + 2) = xint

               uparam(nv + 3) = yint

               IF(xint*yint /= zero)uparam(nv + 1) = 1 ! only tension

C intersection pt of compression if existing

               CALL func_inters_c(titr   ,mat_id ,func   ,fund   ,fac1   ,

     .                            fac2   ,npc    ,pld    ,xinc  ,yinc  )

               uparam(nv + 4) = xinc

               uparam(nv + 5) = yinc

               IF(xinc*yinc /= zero ) THEN

                  IF(int(uparam(nv + 1)) == 0 )THEN

                     uparam(nv + 1) = -1  ! only compression

                   ELSE

                      uparam(nv + 1) = 2  ! tension & compression

                   ENDIF

               ENDIF

           ENDIF

        ENDIF

        WRITE(iout,1000)

        IF(xint*yint > zero) WRITE(iout,1600) xint,yint

        IF(xinc*yinc > zero) WRITE(iout,1700) xinc,yinc

C-----check E_MAX

           emax = zero

           emin = ep20

           eini = zero

          DO j = 1, nfunc

              scalefac= uparam(9 + 2*j )

              CALL func_slope(ifunc(j),scalefac,npc,pld,stiffmin,stiffmax,stiffini,stiffavg)

              emax = max(emax,  stiffmax )

              emin = min(emin,  stiffmin)

              eini = max(eini, stiffini)

          ENDDO ! NFUNC

          nu =uparam(2)

          gs =uparam(3)

          e0 = two*gs*(one + nu)

          ec_max = max(e0,emax)

          pm(24) = ec_max

          WRITE(iout,1003) ec_max

c----- ------

 1000 FORMAT

     & (5x,'TABULATED OGDEN LAW',/,

     &  5x,'-------------',//)

 1600 FORMAT

     & (5x,  'STRAIN TENSION OF INTERSECTION PT BETWEEN QUASISTAIC AND UNLOADING CURVES. . . . .  . . .=',1pg20.13/

     & ,5x,  'STRESS TENSION OF INTERSECTION PT BETWEEN QUASISTAIC AND UNLOADING CURVES. . . . . . . . =',1pg20.13//)


 1700 FORMAT

     & (5x,  'STRAIN COMPRESSION OF INTERSECTION PT BETWEEN QUASISTAIC AND UNLOADING CURVES. . . . .  . . .=',1pg20.13/

     & ,5x,  'STRESS COMPRESSION OF INTERSECTION PT BETWEEN QUASISTAIC AND UNLOADING CURVES. . . . . . . . =',1pg20.13//)

 1003   FORMAT(

     & 5x,'YOUNG''S MODULUS FOR HG COMPUTE . . . .=',1pg20.13/)

      RETURN


      END

my_real
#define my_real
Definition cppsort.cpp:32

func_inters
subroutine func_inters(titr, mat_id, func1, func2, fac1, fac2, npc, pld, xint, yint)
Definition func_inters.F:32

func_inters_c
subroutine func_inters_c(titr, mat_id, func, fund, fac1, fac2, npc, pld, xinc, yinc)
Definition func_inters.F:279

func_slope
subroutine func_slope(idn, fac, npc, pld, stiffmin, stiffmax, stiffini, stiffavg)
Definition func_slope.F:37

law88_upd
subroutine law88_upd(iout, titr, uparam, npc, pld, nfunc, ifunc, mat_id, func_id, pm, nfunct)
Definition law88_upd.F:40

min
#define min(a, b)
Definition macros.h:20

max
#define max(a, b)
Definition macros.h:21

message_mod
Definition message_mod.F:1249

names_and_titles_mod
Definition names_and_titles_mod.F:997

names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003

table_mod
Definition table_mod.F:112

ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889

arret
subroutine arret(nn)
Definition arret.F:87