spadah.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/.
!||====================================================================
!||    spadah        ../engine/source/elements/sph/spadah.F
!||--- called by ------------------------------------------------------
!||    forintp       ../engine/source/elements/forintp.F
!||--- calls      -----------------------------------------------------
!||    ancmsg        ../engine/source/output/message/message.F
!||    arret         ../engine/source/system/arret.F
!||--- uses       -----------------------------------------------------
!||    message_mod   ../engine/share/message_module/message_mod.F
!||====================================================================
      SUBROUTINE spadah(
     1    X       ,V       ,MS      ,SPBUF   ,ITAB    ,
     2    KXSP    ,IXSP    ,NOD2SP  ,WA      ,WASPACT ,
     3    ITASK   ,IPARTSP ,IPART)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
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      "com08_c.inc"
#include      "sphcom.inc"
#include      "task_c.inc"
#include      "scr17_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER KXSP(NISP,*),IXSP(KVOISPH,*),NOD2SP(*),ITAB(*),
     .        WASPACT(*),ITASK,IPARTSP(*),IPART(LIPART1,*)      
C     REAL
      my_real
     .   x(3,*) ,v(3,*) ,ms(*) ,spbuf(nspbuf,*) ,wa(kwasph,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER N,INOD,NVOIS,NS,IPRT,IPROP,H_FLAG
      my_real
     .       XI,YI,ZI,DI,DIVV,COEFF,GET_U_GEO,
     .       hmin,hmax,h_new,di0
C-----------------------------------------------
      EXTERNAL get_u_geo      
C-----------------------------------------------
      DO ns=itask+1,nsphact,nthread
        n=waspact(ns)
        inod =kxsp(3,n)
        nvois=kxsp(4,n)
        xi=x(1,inod)
        yi=x(2,inod)
        zi=x(3,inod)
        di   =spbuf(1,n)
        di0 = spbuf(14,n)
        divv =wa(13,n)
        iprt =ipartsp(n)
        iprop=ipart(2,iprt)
        coeff = get_u_geo(8,iprop)
        h_flag=nint(get_u_geo(9,iprop))
        hmin = get_u_geo(10,iprop)
        hmax = get_u_geo(11,iprop)
C--     H_FLAG = 0 -> 3D dilatation of H : GET_U_GEO(8,IPROP) = 1/3 - HMIN=0 HMAX=EP20
C--     H_FLAG = 1 -> 1D dilatation of H : GET_U_GEO(8,IPROP) = 1   - HMIN=0 HMAX=EP20
C--     H_FLAG = 2 -> Constant H : GET_U_GEO(8,IPROP) = 0           - HMIN=0 HMAX=EP20      
C--     H_FLAG = 3 -> 3D dilatation of H with bounds hmin*h0 < H < hmax*h0     
        h_new=di*(one+divv*dt1*coeff)
        IF (h_flag==3) THEN
          h_new=max(hmin*di0,h_new)
          h_new=min(hmax*di0,h_new)
        ENDIF
        spbuf(1,n)= h_new
        IF(spbuf(1,n)<em20)THEN
          CALL ancmsg(msgid=174,anmode=aninfo,
     .            i1=kxsp(nisp,n))
          CALL arret(2)
        ENDIF
      ENDDO
C-----------------------------------------------
      RETURN
      END