read_impdisp.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/.
!||====================================================================
!||    read_impdisp           ../starter/source/constraints/general/impvel/read_impdisp.F
!||--- called by ------------------------------------------------------
!||    hm_read_impvel         ../starter/source/constraints/general/impvel/hm_read_impvel.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    fretitl                ../starter/source/starter/freform.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_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
!||--- 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 read_impdisp(
     .           NDISP    ,INUM     ,IOPT     ,FBFVEL   ,IBFVEL   ,
     .           ITAB     ,ITABM1   ,IKINE    ,IGRNOD   ,NOM_OPT  ,
     .           ISKN     ,UNITAB   ,LSUBMODEL)
C============================================================================
C   M o d u l e s
C-----------------------------------------------
      USE my_alloc_mod
      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, 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      "scr17_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-----------------------------------------------
      INTEGER ,INTENT(IN)    :: NDISP
      INTEGER ,INTENT(INOUT) :: INUM,IOPT
      INTEGER ,DIMENSION(*)  :: ITAB,ITABM1,IKINE
      INTEGER ,DIMENSION(LISKN,*)        ,INTENT(IN)  :: ISKN
      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
      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,IDISP,NN,IDIS,INOD,NODID,NOSKEW,NOFRAME,LEN,
     .   IUNIT,FLAGUNIT,SENS_ID,OPTID,UID,SKEW_ID,FCT_ID,GRN_ID,IGS,
     .   IFGEO,ICOOR,ILAGM,SUBID,NOSUB,SYS_TYPE,FRAME_ID,J,JJ,NN_FM(3)
      INTEGER ,DIMENSION(:),ALLOCATABLE :: NODENUM
      INTEGER ,DIMENSION(:),ALLOCATABLE :: IKINE1
      my_real :: YSCALE,TSTART,TSTOP,XSCALE,FSCAL_T,FSCAL_L
      CHARACTER(LEN=2)           :: X,Y,Z,XX,YY,ZZ
      CHARACTER(LEN=NCHARFIELD)  :: XYZ
      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  NODGRNR5
      EXTERNAL NODGRNR5
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 DISPLACEMENT DEFINITION  '/
C======================================================================|
      CALL my_alloc(ikine1,3*numnod)
      CALL my_alloc(nodenum,nfxvel)
c
      is_available = .false.
c
      ikine1(:)= 0
      nn_fm(1:3)= 0
c--------------------------------------------------
c     READ /IMPDISP cards
c--------------------------------------------------
c
      CALL hm_option_start('/IMPDISP')
c
      WRITE (iout,1000)
c
c--------------------------------------------------
      DO idisp = 1,ndisp
c--------------------------------------------------
        CALL hm_option_read_key(lsubmodel,
     .                          option_id   = optid,
     .                          unit_id     = uid,
     .                          submodel_id = subid,
     .                          submodel_index = nosub,
     .                          option_titr = titr,
     .                          keyword2    = key)
c--------------------------------------------------
        IF (key(1:4) == 'FGEO')   cycle
c       
        iopt = iopt + 1
        nom_opt(1,iopt) = optid
        CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,iopt),ltitr)
c        
        icoor    = 0  ! ICOOR = 1 => axial coordinates
        ifgeo    = 0
        ilagm    = 0
        idis     = 2
        len      = 1
        noframe  = 0
        sys_type = 1  ! skew = 1 ,frame =2
        noskew = 0
c--------------------------------------------------
c       READ STRING VALUES from /IMPDISP
c--------------------------------------------------
        CALL hm_get_intv('rad_system_input_type'   ,sys_type ,is_available,lsubmodel)
        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'   ,SKEW_ID ,IS_AVAILABLE,LSUBMODEL)
        CALL hm_get_intv  ('rad_sensor_id' ,sens_id ,is_available,lsubmodel)  
        CALL hm_get_intv  ('entityid'      ,grn_id  ,is_available,lsubmodel)  
        CALL hm_get_intv  ('rad_icoor'     ,icoor   ,is_available,lsubmodel)  
        CALL hm_get_intv  ('skew_ID'       ,skew_id  ,is_available,lsubmodel)
        CALL hm_get_intv  ('frame_ID'      ,frame_id ,is_available,lsubmodel)
        IF (sys_type /= 2) CALL hm_get_intv('inputsystem',skew_id ,is_available,lsubmodel)
c
        CALL hm_get_floatv('xscale'        ,xscale  ,is_available,lsubmodel,unitab)
        CALL hm_get_floatv('magnitude'     ,yscale  ,is_available,lsubmodel,unitab)
        CALL hm_get_floatv('rad_tstart'    ,tstart  ,is_available,lsubmodel,unitab)
        CALL hm_get_floatv('rad_tstop'     ,tstop   ,is_available,lsubmodel,unitab)
c
        IF (xyz(1:2) == xx .OR. xyz(1:2) == yy .OR. xyz(1:2) == zz) len = 2
c--------------------------------------------------
c       CHECK IF Unit_ID exists
c--------------------------------------------------
        flagunit = 0
        DO iunit=1,unitab%NUNITS
          IF (unitab%UNIT_ID(iunit) == uid) THEN
            flagunit = 1
            EXIT
          ENDIF
        ENDDO
        IF (uid > 0 .and. flagunit == 0) THEN
          CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
     .                i1= optid,
     .                i2= uid,
     .                c1='IMPDISP',
     .                c2='IMPDISP',
     .                c3= titr)                              
        ENDIF
c--------------------------------------------------
c       Check skew IDs
c-------------------------------------------------- 
        IF ((skew_id == 0).AND.(subid /= 0)) THEN
          skew_id = lsubmodel(nosub)%SKEW
        ENDIF
!
        IF ((sys_type == 0).OR.(sys_type == 1)) THEN
          DO j=0,numskw+min(1,nspcond)*numsph+nsubmod
            IF (skew_id == iskn(4,j+1)) THEN
              noskew = j+1
              EXIT
            ENDIF
          ENDDO
          IF (skew_id > 0 .and. noskew == 0)
     .      CALL ancmsg(msgid=137,anmode=aninfo,msgtype=msgerror,
     .                  i1= optid,
     .                  i2= skew_id,
     .                  c1='IMPOSED DISPLACEMENT',
     .                  c2='IMPOSED DISPLACEMENT',
     .                  c3= titr)
c----
        ELSEIF (sys_type == 2) THEN
          jj = (numskw+1) + min(1,nspcond)*numsph+1 + nsubmod
          DO j=1,numfram
            jj = jj+1
            IF (frame_id == iskn(4,jj)) THEN
              noframe = j+1
              nn_fm(1:3) = iskn(1:3,jj)
              EXIT
            ENDIF
          ENDDO
          IF (frame_id > 0 .and. noframe == 0)
     .      CALL ancmsg(msgid=137,anmode=aninfo,msgtype=msgerror,
     .                  i1= optid,
     .                  i2= frame_id,
     .                  c1='IMPOSED DISPLACEMENT',
     .                  c2='IMPOSED DISPLACEMENT',
     .                  c3= titr)
        ENDIF
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_l ,is_available,lsubmodel,unitab)
c
        IF (xscale == zero) xscale  = one * fscal_t
        xscale = one / xscale
        IF (yscale == zero)  yscale = one * fscal_l
c        IF (LEN == 2) THEN  ! FSCALE = rad - to be checked in cfg file ! 
c          YSCALE = YSCALE / FSCAL_L
c        ENDIF 
        IF (tstop == zero)  tstop  = infinity
c--------------------------------------------------
c       Read NODE numbers from the group
c
        nn = nodgrnr5(grn_id,igs,nodenum,igrnod,itabm1,mess)
c--------------------------------------------------
        DO i=1,nn
          inum  = inum + 1
          ibfvel(1, inum) = nodenum(i)
          ibfvel(2 ,inum) = 0
          ibfvel(3 ,inum) = fct_id
          ibfvel(4 ,inum) = sens_id
          ibfvel(5 ,inum) = 0
          ibfvel(6 ,inum) = 0  ! init dans lecrby (si vitesse de rotation sur main)
          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) = ifgeo
          ibfvel(14,inum) = 0
c
          fbfvel(1,inum)  = yscale
          fbfvel(2,inum)  = tstart
          fbfvel(3,inum)  = tstop
          fbfvel(4,inum)  = zero
          fbfvel(5,inum)  = xscale
          fbfvel(6,inum)  = zero
c
          inod  = iabs(nodenum(i))
          nodid = itab(inod)
c 
c---------------
c         TAG NODES WITH KINEMATIC CONDITIONS
c---------------
          IF (noframe > 0) THEN
            IF(xyz(1:2) == xx)THEN
              ibfvel(2,inum) = 4
              CALL kinset(16,nodid,ikine(inod),4,noframe,ikine1(inod))
            ELSEIF(xyz(1:2) == yy)THEN
              ibfvel(2,inum) = 5
              CALL kinset(16,nodid,ikine(inod),5,noframe,ikine1(inod))
            ELSEIF(xyz(1:2) == zz)THEN
              ibfvel(2,inum) = 6
              CALL kinset(16,nodid,ikine(inod),6,noframe,ikine1(inod))
            ELSEIF (xyz(1:1) == x)THEN
              ibfvel(2,inum) = 1
              CALL kinset(16,nodid,ikine(inod),1,noframe,ikine1(inod))
            ELSEIF(xyz(1:1) == y)THEN
              ibfvel(2,inum) = 2
              CALL kinset(16,nodid,ikine(inod),2,noframe,ikine1(inod))
            ELSEIF(xyz(1:1) == z)THEN
              ibfvel(2,inum) = 3
              CALL kinset(16,nodid,ikine(inod),3,noframe,ikine1(inod))
            ELSE
              CALL ancmsg(msgid=164, msgtype=msgerror, anmode=aninfo,
     .                    i1=optid,
     .                    c1=titr,
     .                    c2=xyz)
            ENDIF
!
            WRITE (iout, 3000) nodid,noskew,frame_id,xyz(1:len),fct_id,sens_id,
     .                         yscale,one/xscale,tstart,tstop,icoor
c---------------
c         check for N1,N2,N3 of frame not the imposed node
c---------------
            IF (inod==nn_fm(1) .OR. inod==nn_fm(2) .OR. inod==nn_fm(3)) THEN
              CALL ancmsg(msgid=3091, msgtype=msgerror, anmode=aninfo,
     .                    i1=optid,
     .                    c1=titr,
     .                    i2=nodid,
     .                    i3=frame_id)
            END IF
          ELSE  ! SKEW
            IF(xyz(1:2) == xx)THEN
              ibfvel(2,inum) = 4 + noskew*10
              CALL kinset(16,nodid,ikine(inod),4,noskew,ikine1(inod))
            ELSEIF(xyz(1:2) == yy)THEN
              ibfvel(2,inum) = 5 + noskew*10
              CALL kinset(16,nodid,ikine(inod),5,noskew,ikine1(inod))
            ELSEIF(xyz(1:2) == zz)THEN
              ibfvel(2,inum) = 6 + noskew*10
              CALL kinset(16,nodid,ikine(inod),6,noskew,ikine1(inod))
            ELSEIF (xyz(1:1) == x)THEN
              ibfvel(2,inum)=1 + noskew*10
              CALL kinset(16,nodid,ikine(inod),1,noskew,ikine1(inod))
            ELSEIF(xyz(1:1) == y)THEN
              ibfvel(2,inum) = 2 + noskew*10
              CALL kinset(16,nodid,ikine(inod),2,noskew,ikine1(inod))
            ELSEIF(xyz(1:1) == z)THEN
              ibfvel(2,inum) = 3 + noskew*10
              CALL kinset(16,nodid,ikine(inod),3,noskew,ikine1(inod))
            ELSE
               CALL ancmsg(msgid=164, msgtype=msgerror, anmode=aninfo,
     .                    i1=optid,
     .                    c1=titr,
     .                    c2=xyz)
            ENDIF
!----------------
            WRITE (iout,2000) nodid,iskn(4,noskew),0,xyz(1:len),fct_id,sens_id,
     .       yscale,one/xscale,tstart,tstop
          ENDIF
c-----------------------------------------------------------
c
        ENDDO ! NN
c
      ENDDO ! DO I=1,NFDISP
c
      DEALLOCATE(ikine1)
      DEALLOCATE(nodenum)
c
c--------------------------------------------------
 1000 FORMAT(//
     .'     IMPOSED DISPLACEMENTS    '/
     .'     -------------------    '/
     .'         NODE         SKEW        FRAME  DIRECTION   LOAD_CURVE',
     .'       SENSOR            FSCALE                ASCALE',
     .'            START_TIME                 STOP_TIME')
 2000 FORMAT(3x,i10,3x,i10,3x,i10,9x,a2,3x,i10,3x,i10,
     .       2x,1pg20.13,2x,1pg20.13,2x,g20.13,2x,g20.13)
 3000 FORMAT(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)
c--------------------------------------------------
      RETURN
      END