hm_read_impvel.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/.
!||====================================================================
!||    hm_read_impvel       ../starter/source/constraints/general/impvel/hm_read_impvel.F
!||--- called by ------------------------------------------------------
!||    lectur               ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    hm_option_count      ../starter/source/devtools/hm_reader/hm_option_count.F
!||    read_impdisp         ../starter/source/constraints/general/impvel/read_impdisp.F
!||    read_impdisp_fgeo    ../starter/source/constraints/general/impvel/read_impdisp_fgeo.F
!||    read_impvel          ../starter/source/constraints/general/impvel/read_impvel.F
!||    read_impvel_fgeo     ../starter/source/constraints/general/impvel/read_impvel_fgeo.F
!||    read_impvel_lagmul   ../starter/source/constraints/general/impvel/read_impvel_lagmul.F
!||    udouble              ../starter/source/system/sysfus.F
!||--- uses       -----------------------------------------------------
!||    hm_option_read_mod   ../starter/share/modules1/hm_option_read_mod.F
!||    message_mod          ../starter/share/message_module/message_mod.F
!||    submodel_mod         ../starter/share/modules1/submodel_mod.F
!||====================================================================
      SUBROUTINE hm_read_impvel(
     .           FBFVEL   ,IBFVEL   ,IKINE    ,IKINE1LAG,
     .           ITAB     ,ITABM1   ,IGRNOD   ,X0       ,IXR      ,
     .           IPART    ,IPARTR   ,ISKN     ,NOM_OPT  ,
     .           NIMPDISP ,NIMPVEL  ,UNITAB   ,LSUBMODEL)
C============================================================================
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE groupdef_mod
      USE submodel_mod
      USE hm_option_read_mod
      USE unitab_mod
      use element_mod , only : nixr
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      "com04_c.inc"
#include      "scr17_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER :: NIMPDISP,NIMPVEL
      INTEGER ,DIMENSION(*)  :: ITAB,ITABM1,IKINE,IKINE1LAG,IPARTR
      INTEGER ,DIMENSION(LISKN,*)           ,INTENT(IN)  :: ISKN
      INTEGER ,DIMENSION(LIPART1,*)         ,INTENT(IN)  :: IPART
      INTEGER ,DIMENSION(NIXR,*)            ,INTENT(IN)  :: IXR
      INTEGER ,DIMENSION(LNOPT1,*)          ,INTENT(OUT) :: NOM_OPT
      INTEGER ,DIMENSION(NIFV,NFXVEL)       ,INTENT(OUT) :: IBFVEL
      my_real ,DIMENSION(LFXVELR,NFXVEL)    ,INTENT(OUT) :: fbfvel
      TYPE(unit_type_),INTENT(IN)  :: UNITAB
      my_real ,DIMENSION(3,NUMNOD)          ,INTENT(IN)  :: x0
      TYPE (GROUP_)      ,DIMENSION(NGRNOD) ,INTENT(IN)  :: IGRNOD
      TYPE(submodel_data),DIMENSION(*)      ,INTENT(IN)  :: LSUBMODEL
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER IOPT,INUM,NOPT,NFDISP,NFVEL,FGEOD,FGEOV,NIMPDISP_0,LAGMULV
      INTEGER ,DIMENSION(:), ALLOCATABLE  :: OPTID
      CHARACTER(nchartitle)  :: MESS
C-----------------------------------------------
C   D a t a
C-----------------------------------------------
      DATA mess/'IMPOSED VELOCITY DEFINITION  '/
C======================================================================|
      inum = 0  ! init index of IBFVEL,FBFVEL (imposed node counter)
      iopt = 0  ! init counter of impdisp, impvel and impacc options
c--------------------------------------------------
c     READ /IMPDISP
c--------------------------------------------------
c           
      CALL hm_option_count('/IMPDISP'     ,nimpdisp )
      nimpdisp_0 = nimpdisp
      CALL hm_option_count('/IMPDISP/FGEO',fgeod)
c
      CALL hm_option_count('/IMPVEL'       ,nimpvel )
      CALL hm_option_count('/IMPVEL/FGEO'  ,fgeov)
      CALL hm_option_count('/IMPVEL/LAGMUL',lagmulv)
c
      nfdisp = nimpdisp - fgeod
      nfvel  = nimpvel  - fgeov - lagmulv
      nopt   = nfdisp + nfvel
c    
c--------------------------------------------------
      IF (nimpdisp > 0) THEN
      
        IF (nfdisp > 0) THEN 
          CALL read_impdisp(
     .         nimpdisp ,inum     ,iopt     ,fbfvel   ,ibfvel   ,
     .         itab     ,itabm1   ,ikine    ,igrnod   ,nom_opt  ,
     .         iskn     ,unitab   ,lsubmodel)
        ENDIF
c
        IF (fgeod > 0) THEN 
          CALL read_impdisp_fgeo(
     .         fgeod    ,inum     ,iopt     ,fbfvel   ,ibfvel   ,
     .         itab     ,itabm1   ,igrnod   ,nom_opt  ,x0       ,
     .         ixr      ,ipart    ,ipartr   ,unitab   ,lsubmodel)
        ENDIF
c
c       TEST DOUBLE IDs of IMPDISP
c
        ALLOCATE( optid(nimpdisp) )
        optid(1:nimpdisp) = nom_opt(1,1:nimpdisp)
        CALL udouble(optid,1,nimpdisp,mess,0,zero)
        DEALLOCATE( optid )
c
      END IF  ! NIMPDISP > 0
      nimpdisp = inum
c
c--------------------------------------------------
c     READ /IMPVEL
c--------------------------------------------------
      IF (nimpvel > 0) THEN
      
c
        IF (nfvel > 0) THEN 
          CALL read_impvel(
     .              nimpvel  ,inum     ,iopt     ,fbfvel   ,ibfvel   ,
     .              itab     ,itabm1   ,ikine    ,ikine1lag,nom_opt  ,
     .              igrnod   ,iskn     ,unitab   ,lsubmodel)
        END IF
c
c       READ /IMPVEL/FGEO
c
        IF (fgeov > 0) THEN 
          CALL read_impvel_fgeo(
     .              fgeov    ,inum     ,iopt     ,fbfvel   ,ibfvel   ,
     .              itab     ,itabm1   ,igrnod   ,nom_opt  ,x0       ,
     .              ixr      ,ipart    ,ipartr   ,unitab   ,lsubmodel)
        END IF
c
c       READ /IMPVEL/LAGMUL
c
        IF (lagmulv > 0) THEN 
          CALL read_impvel_lagmul(
     .              lagmulv  ,inum     ,iopt     ,fbfvel   ,ibfvel   ,
     .              itab     ,itabm1   ,igrnod   ,nom_opt  ,x0       ,
     .              ixr      ,ipart    ,ipartr   ,iskn     ,ikine    ,
     .              unitab   ,lsubmodel)
        END IF
c
c       TEST DOUBLE IDs of IMPVEL
c
        ALLOCATE( optid(nimpvel) )
        optid(1:nimpvel) = nom_opt(1,nimpdisp_0+1:nimpvel+nimpdisp_0)
        CALL udouble(optid,1,nimpvel,mess,0,zero)
        DEALLOCATE( optid )
c
      END IF  ! NIMPVEL > 0
c-----------      
      nimpvel = inum - nimpdisp
      nfxvel  = inum
c--------------------------------------------------
      RETURN
      END