hm_read_impvel.F File Reference

#include "implicit_f.inc"
#include "com04_c.inc"
#include "scr17_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	hm_read_impvel (fbfvel, ibfvel, ikine, ikine1lag, itab, itabm1, igrnod, x0, ixr, ipart, ipartr, iskn, nom_opt, nimpdisp, nimpvel, unitab, lsubmodel)

Function/Subroutine Documentation

hm_read_impvel()

subroutine hm_read_impvel	(	intent(out)	fbfvel,
		integer, dimension(nifv,nfxvel), intent(out)	ibfvel,
		integer, dimension(*)	ikine,
		integer, dimension(*)	ikine1lag,
		integer, dimension(*)	itab,
		integer, dimension(*)	itabm1,
		type (group_), dimension(ngrnod), intent(in)	igrnod,
		intent(in)	x0,
		integer, dimension(nixr,*), intent(in)	ixr,
		integer, dimension(lipart1,*), intent(in)	ipart,
		integer, dimension(*)	ipartr,
		integer, dimension(liskn,*), intent(in)	iskn,
		integer, dimension(lnopt1,*), intent(out)	nom_opt,
		integer	nimpdisp,
		integer	nimpvel,
		type(unit_type_), intent(in)	unitab,
		type(submodel_data), dimension(*), intent(in)	lsubmodel )

Definition at line 40 of file hm_read_impvel.F.

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