#include "implicit_f.inc"
#include "com04_c.inc"
#include "scr17_c.inc"
#include "param_c.inc"
#include "units_c.inc"
Functions/Subroutines
subroutine	read_impvel_fgeo (nfgeo, inum, iopt, fbfvel, ibfvel, itab, itabm1, igrnod, nom_opt, x0, ixr, ipart, ipartr, unitab, lsubmodel)
Function/Subroutine Documentation

◆ read_impvel_fgeo()

subroutine read_impvel_fgeo	(	integer, intent(in)	nfgeo,
		integer, intent(inout)	inum,
		integer, intent(inout)	iopt,
		dimension(lfxvelr,nfxvel)	fbfvel,
		integer, dimension(nifv,nfxvel)	ibfvel,
		integer, dimension(*)	itab,
		integer, dimension(*)	itabm1,
		type (group_), dimension(ngrnod), intent(in)	igrnod,
		integer, dimension(lnopt1,*), intent(out)	nom_opt,
		intent(in)	x0,
		integer, dimension(nixr,*)	ixr,
		integer, dimension(lipart1,*)	ipart,
		integer, dimension(*)	ipartr,
		type (unit_type_), intent(in)	unitab,
		type(submodel_data), dimension(*), intent(in)	lsubmodel )
Definition at line 42 of file read_impvel_fgeo.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
      USE names_and_titles_mod , ONLY : nchartitle, ncharkey
      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"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ,INTENT(IN )    :: NFGEO
      INTEGER ,INTENT(INOUT)  :: INUM,IOPT
      INTEGER ,DIMENSION(*)              :: ITAB,ITABM1,IPARTR
      INTEGER ,DIMENSION(LIPART1,*)      :: IPART
      INTEGER ,DIMENSION(NIXR,*)         :: IXR
      INTEGER ,DIMENSION(NIFV,NFXVEL)    :: IBFVEL
      INTEGER ,DIMENSION(LNOPT1,*) ,INTENT(OUT) :: NOM_OPT
      my_real ,DIMENSION(LFXVELR,NFXVEL) :: fbfvel
      my_real ,DIMENSION(3,NUMNOD) ,INTENT(IN):: x0
      TYPE (UNIT_TYPE_)  ,INTENT(IN) ::  UNITAB
      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 I,J,K,N,N1,N2,NUM0,IFGEO,JPART,NNOD,NOFRAME,
     .   SENS_ID,PART_ID,OPTID,UID,FCT1_ID,FCT2_ID,ILAGM,
     .   FGEO,IDIS,ICOOR
      INTEGER ,DIMENSION(NUMNOD)   :: NOD1,NOD2
      my_real :: tstart,xscale,yscale,fscal_t,fscal_v,t0,dmin,dist,
     .   xi,yi,zi,xf,yf,zf
      CHARACTER(LEN=NCHARKEY)    :: KEY
      CHARACTER(LEN=NCHARTITLE)  :: TITR,MESS
      LOGICAL IS_AVAILABLE
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      INTEGER  USR2SYS
      EXTERNAL usr2sys
C-----------------------------------------------
C   D a t a
C-----------------------------------------------
      DATA mess/'IMPOSED VELOCITY DEFINITION  '/
C======================================================================|
      is_available = .false.
 
      num0     = inum+1
c--------------------------------------------------
c
      CALL hm_option_start('/IMPVEL/FGEO')
c
c--------------------------------------------------
      DO ifgeo = 1,nfgeo
c--------------------------------------------------
        CALL hm_option_read_key(lsubmodel,
     .                          option_id   = optid,
     .                          unit_id     = uid,
     .                          option_titr = titr,
     .                          keyword2    = key)
c        
        iopt = iopt + 1
        nom_opt(1,iopt) = optid
        CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,iopt),ltitr)
c        
c--------------------------------------------------
        icoor    = 0
        fgeo     = 2
        idis     = 0
        ilagm    = 0
        noframe  = 0
c--------------------------------------------------
c       READ STRING VALUES from /IMPVEL
c--------------------------------------------------
c        CALL HM_GET_INTV  ('distribution'  ,DISTRIBUTION ,IS_AVAILABLE,LSUBMODEL)
c        
        CALL hm_get_intv  ('curveid'        ,fct1_id ,is_available,lsubmodel)
        CALL hm_get_intv  ('rad_spring_part',part_id ,is_available,lsubmodel)
        CALL hm_get_intv  ('rad_fct_l_id'   ,fct2_id ,is_available,lsubmodel)
        CALL hm_get_intv  ('rad_sensor_id'  ,sens_id ,is_available,lsubmodel)
c        
        CALL hm_get_floatv('xscale'         ,xscale  ,is_available,lsubmodel,unitab)
        CALL hm_get_floatv('rad_t0'         ,t0      ,is_available,lsubmodel,unitab)
        CALL hm_get_floatv('rad_tstart'     ,tstart  ,is_available,lsubmodel,unitab)
        CALL hm_get_floatv('magnitude'      ,YSCALE  ,IS_AVAILABLE,LSUBMODEL,UNITAB)
        CALL HM_GET_FLOATV('rad_dmin'       ,DMIN    ,IS_AVAILABLE,LSUBMODEL,UNITAB)
c
        CALL HM_GET_INTV('distribution_table_count' ,NNOD ,IS_AVAILABLE,LSUBMODEL)
        DO I = 1,NNOD
          CALL HM_GET_INT_ARRAY_INDEX('location_unit_node' ,NOD1(I) ,I ,IS_AVAILABLE, LSUBMODEL)                             
          CALL HM_GET_INT_ARRAY_INDEX('rad_node_id'        ,NOD2(I) ,I ,IS_AVAILABLE, LSUBMODEL)                             
        ENDDO
c
c--------------------------------------------------
c       Default scale factors
c--------------------------------------------------
        IF (T0 <= ZERO) THEN
          CALL ANCMSG(MSGID=1074, MSGTYPE=MSGERROR, ANMODE=ANINFO,
     .                I1=OPTID, C1=TITR, R1=T0)
          CALL HM_GET_FLOATV_DIM('rad_t0'   ,FSCAL_T ,IS_AVAILABLE,LSUBMODEL,UNITAB)
          T0 = ONE * FSCAL_T 
        ENDIF
        IF (XSCALE == ZERO) THEN
          CALL HM_GET_FLOATV_DIM('xscale'    ,FSCAL_T ,IS_AVAILABLE,LSUBMODEL,UNITAB)
          XSCALE = ONE * FSCAL_T
        ENDIF
        IF (YSCALE == ZERO) THEN
          CALL HM_GET_FLOATV_DIM('magnitude' ,FSCAL_V ,IS_AVAILABLE,LSUBMODEL,UNITAB)
          YSCALE = ONE * FSCAL_V
        ENDIF
c
        WRITE (IOUT,1000)
c--------------------------------------------------
c       Treatment of explicitly defined nodes
c--------------------------------------------------
        DO J=1,NNOD
              
          N2 = USR2SYS(NOD2(J),ITABM1,MESS,OPTID)
          XF = X0(1,N2)   
          YF = X0(2,N2)   
          ZF = X0(3,N2)
c
          IF (NOD1(J) > 0) THEN  
            INUM = INUM + 1
            N1 = USR2SYS(NOD1(J),ITABM1,MESS,OPTID)
            XI = X0(1,N1)
            YI = X0(2,N1)
            ZI = X0(3,N1)
            DIST = SQRT((XF-XI)**2 + (YF-YI)**2 + (ZF-ZI)**2)
c
            IBFVEL(1 ,INUM) = N1
            IBFVEL(2 ,INUM) = 0
            IBFVEL(3 ,INUM) = FCT1_ID
            IBFVEL(4 ,INUM) = SENS_ID
            IBFVEL(5 ,INUM) = 0
            IBFVEL(6 ,INUM) = 0 
            IBFVEL(7 ,INUM) = IDIS
            IBFVEL(8 ,INUM) = ILAGM
            IBFVEL(9 ,INUM) = NOFRAME
            IBFVEL(10,INUM) = ICOOR
            IBFVEL(11,INUM) = 0
            IBFVEL(12,INUM) = IOPT
            IBFVEL(13,INUM) = FGEO
            IBFVEL(14,INUM) = N2
            IBFVEL(15,INUM) = FCT2_ID
c
            FBFVEL(1,INUM)  = DIST / T0
            FBFVEL(2,INUM)  = TSTART
            FBFVEL(3,INUM)  = INFINITY
            FBFVEL(4,INUM)  = ZERO
            FBFVEL(5,INUM)  = XSCALE
            FBFVEL(6,INUM)  = ZERO
            FBFVEL(7,INUM)  = DMIN
            FBFVEL(8,INUM)  = YSCALE
c
            WRITE (IOUT,2000) ITAB(N1),ITAB(N2),FCT1_ID,SENS_ID,FCT2_ID,
     .                        DIST/T0,ONE/XSCALE,TSTART,DMIN,YSCALE
          END IF
        END DO
c--------------------------------------------------
c       Treatment of nodes defined by spring part
c--------------------------------------------------
        IF (PART_ID > 0) THEN
          JPART = 0
          DO N=1,NPART
            IF (IPART(4,N) == PART_ID) JPART = N
          ENDDO
c            
          DO N=1,NUMELR
            IF (IPARTR(N) == JPART) THEN
              INUM = INUM + 1
              N1  = IXR(2,N)
              N2  = IXR(3,N)
              XI  = X0(1,N1)
              YI  = X0(2,N1)
              ZI  = X0(3,N1)
              XF  = X0(1,N2)
              YF  = X0(2,N2)
              ZF  = X0(3,N2)
              DIST= SQRT((XF-XI)**2 + (YF-YI)**2 + (ZF-ZI)**2)
c
              IBFVEL(1 ,INUM) = N1
              IBFVEL(2 ,INUM) = 0
              IBFVEL(3 ,INUM) = FCT1_ID
              IBFVEL(4 ,INUM) = SENS_ID
              IBFVEL(5 ,INUM) = 0
              IBFVEL(6 ,INUM) = 0
              IBFVEL(7 ,INUM) = IDIS
              IBFVEL(8 ,INUM) = ILAGM
              IBFVEL(9 ,INUM) = NOFRAME
              IBFVEL(10,INUM) = ICOOR
              IBFVEL(11,INUM) = 0
              IBFVEL(12,INUM) = IOPT
              IBFVEL(13,INUM) = FGEO
              IBFVEL(14,INUM) = N2
              IBFVEL(15,INUM) = FCT2_ID
c
              FBFVEL(1,INUM)  = DIST / T0
              FBFVEL(2,INUM)  = TSTART
              FBFVEL(3,INUM)  = INFINITY
              FBFVEL(4,INUM)  = ZERO
              FBFVEL(5,INUM)  = XSCALE
              FBFVEL(6,INUM)  = ZERO
              FBFVEL(7,INUM)  = DMIN
              FBFVEL(8,INUM)  = YSCALE
c
              WRITE (IOUT,2000) ITAB(N1),ITAB(N2),FCT1_ID,SENS_ID,FCT2_ID,
     .                          DIST/T0,ONE/XSCALE,TSTART,DMIN,YSCALE
            END IF
          END DO
        END IF  ! PART_ID > 0
c----------------------------------------------------------------------    
c       /IMPVEL/FGEO CALCULE LE NOMBRE D'OCCURENCES D'ONE NOEUD DE DESTINATION
c--------------------------------------------------
        DO N = 1,INUM
          IF (IBFVEL(13,N) /= 2) CYCLE
          N2 = IBFVEL(14,N)
          K  = 1
          DO I = 1,INUM
            IF (I == N) CYCLE
            IF (IBFVEL(13,I) /= 2) CYCLE
            IF (IBFVEL(14,I) == N2) K = K + 1
          END DO
          IBFVEL(16,N) = K
        END DO
c-----------
      END DO  ! IFGEO = 1,NFGEO
c----------------------------------------------------------------------    
 1000 FORMAT(//
     .'     imposed velocities  prescribed final geometry '/
     .'     ----------------------------------------------'/
     .'      node1      node2  vel_curve     sensor load_curve ',
     .'      fscale           ascale       start_time           ',
     .'      dmin   load_scale')
 2000 FORMAT(5(1X,I10),5(1X,1PG16.9))
c----------------------------------------------------------------------    
      RETURN
OpenRadioss 2025.1.11 OpenRadioss project
Functions/Subroutines

Function/Subroutine Documentation

◆ read_impvel_fgeo()
