read_impvel_lagmul.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_impvel_lagmul     ../starter/source/constraints/general/impvel/read_impvel_lagmul.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
!||    usr2sys                ../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 read_impvel_lagmul(
     .           NLAGMUL  ,INUM     ,IOPT     ,FBFVEL   ,IBFVEL   ,
     .           ITAB     ,ITABM1   ,IGRNOD   ,NOM_OPT  ,X0       ,
     .           IXR      ,IPART    ,IPARTR   ,ISKN     ,IKINE    ,
     .           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 names_and_titles_mod , ONLY : nchartitle, ncharkey, ncharfield
      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      "sphcom.inc"
#include      "lagmult.inc"
#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 )    :: NLAGMUL
      INTEGER ,INTENT(INOUT)  :: INUM,IOPT
      INTEGER ,DIMENSION(*)              :: ITAB,ITABM1,IPARTR,IKINE
      INTEGER ,DIMENSION(LIPART1,*)      :: IPART
      INTEGER ,DIMENSION(NIXR,*)         :: IXR
      INTEGER ,DIMENSION(NIFV,NFXVEL)    :: IBFVEL
      INTEGER ,DIMENSION(LISKN,*),INTENT(IN)  :: ISKN
      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 J,NOD,NUM0,ILAGMUL,IUN,NNOD,NOFRAME,INOD,NOSKEW,
     .   SENS_ID,OPTID,UID,FCT1_ID,ILAGM,GRNOD_ID,IGS,LEN,
     .   IDIS,ICOOR,SKEW_ID
      INTEGER ,DIMENSION(NUMNOD)   :: NWORK 
      INTEGER ,DIMENSION(3*NUMNOD) :: IKINE1
      my_real :: XSCALE,YSCALE,FSCAL_T,FSCAL_V,
     .   TSTART,TSTOP
      CHARACTER(LEN=NCHARKEY)    :: KEY
      CHARACTER(LEN=NCHARFIELD)  :: XYZ
      CHARACTER(LEN=NCHARTITLE)  :: TITR,MESS
      CHARACTER(LEN=2)           :: X,Y,Z,XX,YY,ZZ
      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,USR2SYS
      EXTERNAL NODGRNR5,USR2SYS
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 iun/1/
      DATA mess/'IMPOSED VELOCITY DEFINITION  '/
C======================================================================|
      is_available = .false.
 
      num0     = inum+1
c
      ikine1(:) = 0
c--------------------------------------------------
c
      CALL hm_option_start('/IMPVEL/LAGMUL')
c
c--------------------------------------------------
      DO ilagmul = 1,nlagmul
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
        idis     = 1
        ilagm    = 1
        noframe  = 0
        sens_id  = 0
        len      = 1
        tstart   = zero
        tstop    = infinity
c--------------------------------------------------
c       READ STRING VALUES from /IMPVEL/LAGMUL
c--------------------------------------------------        
        CALL hm_get_intv  ('curveid'   ,fct1_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  ('entityid'       ,grnod_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)
c--------------------------------------------------
c       
c--------------------------------------------------
         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 VELOCITY',
     .                  c2='IMPOSED VELOCITY',
     .                  c3= titr)
 
 
c--------------------------------------------------
        IF (xscale == zero) THEN
          CALL hm_get_floatv_dim('xscale'    ,fscal_t ,is_available,lsubmodel,unitab)
          xscale = fscal_t
        ENDIF
        IF (yscale == zero) THEN
          CALL hm_get_floatv_dim('magnitude' ,fscal_v ,is_available,lsubmodel,unitab)
          yscale =  fscal_v
        ENDIF
c
        IF (xyz(1:2) == xx .OR. xyz(1:2) == yy .OR. xyz(1:2) == zz) THEN
          len = 2
        ENDIF
        WRITE (iout,1000)
c       Read NODE numbers from the group
        nnod = nodgrnr5(grnod_id    ,igs    ,nwork,igrnod   ,itabm1 ,mess   )
               
 
        nfvlag = nfvlag+nnod
        lag_ncf = lag_ncf + nnod
        lag_nhf = lag_nhf + nnod
        IF(noskew == 0) THEN
           lag_nkf = lag_nkf + nnod
        ELSE
           lag_nkf = lag_nkf + nnod*3
        ENDIF
c--------------------------------------------------
c       Treatment of explicitly defined nodes
c--------------------------------------------------
        DO j=1,nnod
            inum = inum + 1   
            inod = iabs(nwork(j))          
            nod  = itab(inod)
c
            ibfvel(1 ,inum) = nwork(j)
            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) = 0
            ibfvel(14,inum) = 0
c
 
c
            fbfvel(1,inum)  = yscale
            fbfvel(2,inum)  = tstart
            fbfvel(3,inum)  = tstop
            fbfvel(4,inum)  = zero
            fbfvel(5,inum)  = one/xscale
            fbfvel(6,inum)  = zero
 
            IF(xyz(1:2) == xx)THEN
              ibfvel(2,inum) = 4 + noskew*10
              CALL kinset(16,nod,ikine(inod),4,noskew,ikine1(inod))
            ELSEIF(xyz(1:2) == yy)THEN
              ibfvel(2,inum) = 5 + noskew*10
              CALL kinset(16,nod,ikine(inod),5,noskew,ikine1(inod))
            ELSEIF(xyz(1:2) == zz)THEN
              ibfvel(2,inum) = 6 + noskew*10
              CALL kinset(16,nod,ikine(inod),6,noskew,ikine1(inod))
            ELSEIF (xyz(1:1) == x)THEN
              ibfvel(2,inum)=1 + noskew*10
              CALL kinset(16,nod,ikine(inod),1,noskew,ikine1(inod))
            ELSEIF(xyz(1:1) == y)THEN
              ibfvel(2,inum) = 2 + noskew*10
              CALL kinset(16,nod,ikine(inod),2,noskew,ikine1(inod))
            ELSEIF(xyz(1:1) == z)THEN
              ibfvel(2,inum) = 3 + noskew*10
              CALL kinset(16,nod,ikine(inod),3,noskew,ikine1(inod))
            ELSE
               CALL ancmsg(msgid=164, msgtype=msgerror, anmode=aninfo,
     .                    i1=optid,
     .                    c1=titr,
     .                    c2=xyz)
            ENDIF
c
 
            WRITE (iout,4000) nod,iskn(4,noskew),0,xyz(1:len),fct1_id,sens_id,
     .         yscale,xscale,tstart,tstop,0
        END DO
c-----------
      END DO  ! 
c----------------------------------------------------------------------    
 1000 FORMAT(//
     .'     IMPOSED VELOCITIES BY LAGRANGE MULTIPLIERS'/
     .'     ------------------------------------------'/
     .'         NODE         SKEW        FRAME  DIRECTION   LOAD_CURVE',
     .'       SENSOR       FSCALE                ASCALE')
 
 4000 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