hm_read_impacc.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_impacc         ../starter/source/constraints/general/impvel/hm_read_impacc.F
!||--- called by ------------------------------------------------------
!||    lectur                 ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    hm_get_floatv          ../starter/source/devtools/hm_reader/hm_get_floatv.F
!||    hm_get_floatv_dim      ../starter/source/devtools/hm_reader/hm_get_floatv_dim.F
!||    hm_get_intv            ../starter/source/devtools/hm_reader/hm_get_intv.F
!||    hm_get_string          ../starter/source/devtools/hm_reader/hm_get_string.F
!||    hm_option_count        ../starter/source/devtools/hm_reader/hm_option_count.F
!||    hm_option_read_key     ../starter/source/devtools/hm_reader/hm_option_read_key.F
!||    hm_option_start        ../starter/source/devtools/hm_reader/hm_option_start.F
!||    kinset                 ../starter/source/constraints/general/kinset.F
!||    nodgrnr5               ../starter/source/starter/freform.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_impacc(
     .           FAC      ,IBFV     ,NFXVEL0  ,ITAB     ,ITABM1   ,
     .           IKINE    ,IGRNOD   ,ISKN     ,UNITAB   ,LSUBMODEL,
     .           NUM      ,NIMPACC  )
C============================================================================
C   M o d u l e s
C-----------------------------------------------
      USE unitab_mod
      USE message_mod
      USE groupdef_mod
      USE submodel_mod
      USE hm_option_read_mod
      USE names_and_titles_mod , ONLY : nchartitle, ncharfield
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      "param_c.inc"
#include      "sphcom.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB 
      INTEGER ,INTENT(INOUT) :: NIMPACC,NUM
      INTEGER ,INTENT(IN)    :: NFXVEL0
      INTEGER ,DIMENSION(NIFV,NFXVEL0) :: IBFV
      INTEGER ,DIMENSION(LISKN,*)      :: ISKN
      INTEGER ,DIMENSION(*)            :: ITAB,ITABM1,IKINE
      my_real,DIMENSION(LFXVELR,*) ,INTENT(INOUT) :: fac
 
      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 J,ID,UID,IACC,FCT_ID,INP_ID,SENS_ID,GRN,NACC,
     .        NOSKEW,NOFRAME,NUM0,NN,I_VDA,INOD,NODID,IGS,
     .        L_XYZ,SUBID,NOSUB,NODENUM(NFXVEL0)
      INTEGER ,DIMENSION(3*NUMNOD) :: IKINE1
      LOGICAL IS_AVAILABLE
      CHARACTER(LEN=NCHARFIELD) :: XYZ
      CHARACTER(LEN=NCHARTITLE) :: TITR,MESS
      INTEGER ,DIMENSION(:),ALLOCATABLE  :: IACCIDS
      CHARACTER(LEN=2) :: X,Y,Z,XX,YY,ZZ
      my_real :: fac1,fac2,fac3,facx,fscal_t,fscal_a,bid
C-----------------------------------------------
C   D a t a
C-----------------------------------------------
      DATA x  /'X'/
      DATA y  /'Y'/
      DATA z  /'Z'/
      DATA xx /'XX'/
      DATA yy /'YY'/
      DATA zz /'ZZ'/
      DATA mess/'IMPOSED ACCELERATION DEFINITION  '/
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      INTEGER  NODGRNR5
      EXTERNAL NODGRNR5
C======================================================================|
!---
      WRITE (iout,1000)
!---
!---
      i_vda = num ! (VDA ---> velocities + desplacements + accelerations)
!---
      ikine1(1:3*numnod) = 0
      nodenum(1:nfxvel0) = 0
      bid  = zero
      nacc = 0
c--------------------------------------------------
c     COUNT /IMPACC Options
c--------------------------------------------------
      CALL hm_option_count('/IMPACC',nimpacc)
!
      ALLOCATE(iaccids(nimpacc))
      iaccids(1:nimpacc) = 0
!
      is_available = .false.
C--------------------------------------------------
C START BROWSING MODEL /IMPACC
C--------------------------------------------------
      CALL hm_option_start('/IMPACC')
C--------------------------------------------------
C BROWSING MODEL IMPACC 1-> NIMPACC
C--------------------------------------------------
      DO iacc=1,nimpacc
        titr = ''
C--------------------------------------------------
C EXTRACT DATAS OF /IMPACC/... LINE
C--------------------------------------------------
        CALL hm_option_read_key(lsubmodel,
     .                          option_id   = id,
     .                          unit_id     = uid,
     .                          submodel_id = subid,
     .                          submodel_index = nosub,
     .                          option_titr = titr)
!
        iaccids(iacc) = id
!
C--------------------------------------------------
C EXTRACT DATA (STRING VALUES)
C--------------------------------------------------
        CALL hm_get_intv('curveid'        ,fct_id  ,is_available,lsubmodel)
        CALL hm_get_string('rad_dir'      ,xyz     ,ncharfield,is_available)
        CALL hm_get_intv('inputsystem'    ,inp_id  ,is_available,lsubmodel)
        CALL hm_get_intv('rad_sensor_id'  ,sens_id ,is_available,lsubmodel)
        CALL hm_get_intv('entityid'       ,grn     ,is_available,lsubmodel)
!
        CALL hm_get_floatv('xscale'       ,facx,is_available,lsubmodel,unitab)
        CALL hm_get_floatv('magnitude'    ,fac1,is_available,lsubmodel,unitab)
        CALL hm_get_floatv('rad_tstart'   ,FAC2,IS_AVAILABLE,LSUBMODEL,UNITAB)
        CALL HM_GET_FLOATV('rad_tstop'    ,FAC3,IS_AVAILABLE,LSUBMODEL,UNITAB)
c--------------------------------------------------
c       Check skew and frame IDs
c--------------------------------------------------
.AND.        IF ((INP_ID == 0)(SUBID /= 0)) THEN
          INP_ID = LSUBMODEL(NOSUB)%SKEW
        ENDIF
c----
        NOSKEW  = 0
        NOFRAME = 0
c----
        DO J=0,NUMSKW+MIN(1,NSPCOND)*NUMSPH+NSUBMOD
          IF (INP_ID == ISKN(4,J+1)) THEN               
            NOSKEW = J+1                         
            EXIT                           
          ENDIF                                   
        ENDDO
.and.        IF (INP_ID > 0  NOSKEW == 0)
     .    CALL ANCMSG(MSGID=137,ANMODE=ANINFO,MSGTYPE=MSGERROR,
     .                I1= ID,
     .                I2= NOSKEW,
     .                C1='imposed acceleration',
     .                c2='IMPOSED ACCELERATION',
     .                c3= titr)
c----
c--------------------------------------------------
c       Default scale factors
c--------------------------------------------------
        CALL hm_get_floatv_dim('xscale'   ,fscal_t ,is_available,lsubmodel,unitab)
        CALL hm_get_floatv_dim('magnitude',fscal_a ,is_available,lsubmodel,unitab)
        IF (facx == zero) facx = one * fscal_t
        facx = one / facx
        IF (fac1 == zero) fac1 = one * fscal_a
        IF (fac3 == zero) fac3 = ep20
c--------------------------------------------------
        IF (xyz(1:2) == xx .OR. xyz(1:2) == yy .OR. xyz(1:2) == zz) THEN
          fac1 = fac1 /  (fscal_a * fscal_t * fscal_t)
        ENDIF
!---
        num0 = num
        nn   = nodgrnr5(grn,igs,nodenum,igrnod,itabm1,mess)
        num  = num  + nn
        nacc = nacc + nn
!
        DO j=1,nn
          i_vda = i_vda + 1
          ibfv(1,i_vda)  = nodenum(j)
          ibfv(2,i_vda)  = 0
          ibfv(3,i_vda)  = fct_id
          ibfv(4,i_vda)  = sens_id
          ibfv(5,i_vda)  = 0
          ibfv(6,i_vda)  = 0  ! init dans lecrby (si vitesse de rotation sur main)
          ibfv(7,i_vda)  = 0
          ibfv(8,i_vda)  = 0
          ibfv(9,i_vda)  = noframe
          ibfv(10,i_vda) = 0
          ibfv(11,i_vda) = 0
          ibfv(12,i_vda) = iacc
          ibfv(13,i_vda) = 0
          ibfv(14,i_vda) = 0
!
          fac(1,i_vda)= fac1
          fac(2,i_vda)= fac2
          fac(3,i_vda)= fac3
          fac(4,i_vda)= zero
          fac(5,i_vda)= facx
          fac(6,i_vda)= zero
!
          inod  = iabs(nodenum(j))
          nodid = itab(inod)
!---
!  PRINT OUT
!---
          l_xyz = 0
          IF (xyz(1:2) == xx .OR. xyz(1:2) == yy .OR. xyz(1:2) == zz) THEN
            l_xyz = 2
          ELSEIF (xyz(1:1) == x .OR. xyz(1:1) == y .OR. xyz(1:1) == z) THEN
            l_xyz = 1
          ENDIF
!
          WRITE (iout,'(3X,I10,3X,I10,3X,I10,9X,A2,3X,I10,3X,I10,2X,
     .       1PG20.13,2X,1PG20.13,2X,G20.13,2X,G20.13,16X,I10)')
     .       nodid,iskn(4,noskew),0,xyz(1:l_xyz),ibfv(3,i_vda),sens_id,
     .       fac(1,i_vda),one/facx,fac(2,i_vda),fac(3,i_vda),ibfv(10,i_vda)
!
          IF (xyz(1:2) == xx) THEN
            ibfv(2,i_vda) = 4 + noskew*10
            CALL kinset(16,nodid,ikine(inod),4,noskew,ikine1(inod))
          ELSEIF (xyz(1:2) == yy) THEN
            ibfv(2,i_vda) = 5 + noskew*10
            CALL kinset(16,nodid,ikine(inod),5,noskew,ikine1(inod))
          ELSEIF (xyz(1:2) == 'ZZ') THEN
            ibfv(2,i_vda) = 6 + noskew*10
            CALL kinset(16,nodid,ikine(inod),6,noskew,ikine1(inod))
          ELSEIF (xyz(1:1) == x) THEN
            ibfv(2,i_vda)= 1 + noskew*10
            CALL kinset(16,nodid,ikine(inod),1,noskew,ikine1(inod))
          ELSEIF (xyz(1:1) == y) THEN
            ibfv(2,i_vda) = 2 + noskew*10
            CALL kinset(16,nodid,ikine(inod),2,noskew,ikine1(inod))
          ELSEIF (xyz(1:1) == 'Z') THEN
            ibfv(2,i_vda) = 3 + noskew*10
            CALL kinset(16,nodid,ikine(inod),3,noskew,ikine1(inod))
          ELSE
             CALL ancmsg(msgid=164,
     .                   msgtype=msgerror,
     .                   anmode=aninfo,i1=id,
     .                   c1=titr,
     .                   c2=xyz)
          ENDIF ! IF (XYZ(1:1) == X)
        ENDDO ! DO J=1,NN
!---------------------------
      ENDDO ! DO IACC=1,NIMPACC
c-----------
c     TEST DOUBLE IDs
c-----------
!
      CALL udouble(iaccids,1,nimpacc,mess,0,bid)
c
      nimpacc = nacc
!
C-----
      DEALLOCATE(iaccids)
C-----
 1000 FORMAT(//
     .'     IMPOSED ACCELERATIONS   '/
     .'     ---------------------   '/
     .'         NODE         SKEW        FRAME  DIRECTION   LOAD_CURVE',
     .'       SENSOR            FSCALE                ASCALE',
     .'            START_TIME                 STOP_TIME')
C-----
      RETURN
      END