fstr_ctrl_static.f90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
module fstr_ctrl_static
  use m_fstr
  use hecmw
  use fstr_ctrl_util_f
 
  private :: pc_strupr
contains
 
  subroutine pc_strupr( s )
    implicit none
    character(*) :: s
    integer :: i, n, a, da
 
    n = len_trim(s)
    da = iachar('a') - iachar('A')
    do i = 1, n
      a = iachar(s(i:i))
      if( a > iachar('Z')) then
        a = a - da
        s(i:i) = achar(a)
      end if
    end do
  end subroutine pc_strupr
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_static( ctrl, &
      & dtime, etime, itime, eps, restart_nout, &
      & idx_elpl, &
      & iout_list, &
      & sig_y0, h_dash, &
      & nout, nout_monit, node_monit_1, elem_monit_1, intg_monit_1 )
    implicit none
    integer(kind=kint) :: ctrl
    real(kind=kreal)   :: dtime
    real(kind=kreal)   :: etime
    integer(kind=kint) :: itime
    real(kind=kreal)   :: eps
    integer(kind=kint) :: restart_nout
    integer(kind=kint) :: idx_elpl
    real(kind=kreal)   :: sig_y0, h_dash
    integer(kind=kint) :: nout, nout_monit, node_monit_1, elem_monit_1, intg_monit_1
    integer(kind=kint) :: iout_list(6)
    integer(kind=kint) :: fstr_ctrl_get_static
 
    fstr_ctrl_get_static = -1
 
    if( fstr_ctrl_get_data_ex( ctrl, 1, 'rriri ', dtime, etime, itime, eps, restart_nout ) /= 0 ) return
    if( fstr_ctrl_get_data_ex( ctrl, 2, 'i ', idx_elpl ) /= 0 ) return
    if( fstr_ctrl_get_data_ex( ctrl, 3, 'iiiiii ', &
      & iout_list(1), iout_list(2), iout_list(3), iout_list(4), iout_list(5), iout_list(6)) /= 0 ) return
    if( fstr_ctrl_get_data_ex( ctrl, 4, 'rr ', sig_y0, h_dash ) /= 0 ) return
    if( fstr_ctrl_get_data_ex( ctrl, 5, 'iiiii ', &
      & nout, nout_monit, node_monit_1, elem_monit_1, intg_monit_1 ) /= 0 ) return
 
    fstr_ctrl_get_static = 0
  end function fstr_ctrl_get_static
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_boundary( ctrl, amp, node_id, node_id_len, dof_ids, dof_ide, value )
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp
    character(len=HECMW_NAME_LEN) :: node_id(:)
    integer(kind=kint) :: node_id_len
    integer(kind=kint),pointer :: dof_ids (:)
    integer(kind=kint),pointer :: dof_ide (:)
    real(kind=kreal),pointer :: value(:)
    integer(kind=kint) :: fstr_ctrl_get_boundary
 
    character(len=HECMW_NAME_LEN) :: data_fmt,ss
    write(ss,*)  node_id_len
    write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'IIr '
 
    fstr_ctrl_get_boundary = -1
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP ',  '# ',  0, 'S', amp )/= 0) return
    fstr_ctrl_get_boundary = &
      fstr_ctrl_get_data_array_ex( ctrl, data_fmt, node_id, dof_ids, dof_ide, value )
 
  end function fstr_ctrl_get_boundary
 
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_cload( ctrl, amp, node_id, node_id_len, dof_id, value )
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp
    character(len=HECMW_NAME_LEN) :: node_id(:)
    integer(kind=kint) :: node_id_len
    integer(kind=kint),pointer :: dof_id(:)
    real(kind=kreal),pointer :: value(:)
    integer(kind=kint) :: fstr_ctrl_get_cload
 
    character(len=HECMW_NAME_LEN) :: data_fmt,ss
    write(ss,*)  node_id_len
    write( data_fmt, '(a,a,a)') 'S', trim(adjustl(ss)), 'IR '
 
    fstr_ctrl_get_cload = -1
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP ',  '# ',  0, 'S', amp )/= 0) return
    fstr_ctrl_get_cload = &
      fstr_ctrl_get_data_array_ex( ctrl, data_fmt, node_id, dof_id, value )
 
  end function fstr_ctrl_get_cload
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_dload( ctrl, amp, follow, element_id, element_id_len, load_type, params )
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp
    integer(kind=kint) :: follow
    character(len=HECMW_NAME_LEN) :: element_id(:)
    integer(kind=kint) :: element_id_len
    integer(kind=kint),pointer :: load_type(:)
    real(kind=kreal),pointer :: params(:,:)
    integer(kind=kint) :: fstr_ctrl_get_dload
 
    character(len=HECMW_NAME_LEN),pointer :: type_name_list(:)
 
    integer(kind=kint) :: i, n
    integer(kind=kint) :: rcode
    character(len=HECMW_NAME_LEN) :: data_fmt,s1,s2
    integer(kind=kint) :: lid
 
    fstr_ctrl_get_dload = -1
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP ',  '# ',  0, 'S', amp )/= 0) return
    follow = follow+1
    if( fstr_ctrl_get_param_ex( ctrl, 'FOLLOW ','NO,YES ', 0, 'P', follow ) /= 0) return
    follow = follow-1
 
    write(s1,*)  element_id_len
    write(s2,*)  hecmw_name_len
    write( data_fmt, '(a,a,a,a,a)') 'S', trim(adjustl(s1)), 'S', trim(adjustl(s2)),'Rrrrrrr '
 
    n = fstr_ctrl_get_data_line_n(ctrl)
    allocate( type_name_list(n) )
 
      block
        real(kind=kreal) :: params0(n), params1(n), params2(n), params3(n), params4(n), params5(n), params6(n)
        params0 = params(0,:)
        params1 = params(1,:)
        params2 = params(2,:)
        params3 = params(3,:)
        params4 = params(4,:)
        params5 = params(5,:)
        params6 = params(6,:)
        rcode = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, element_id, type_name_list, &
          params0, params1, params2, params3, params4, params5, params6 )
        params(0,:) = params0
        params(1,:) = params1
        params(2,:) = params2
        params(3,:) = params3
        params(4,:) = params4
        params(5,:) = params5
        params(6,:) = params6
      end block
 
      if( rcode /= 0 ) then
        deallocate( type_name_list )
        return
      end if
 
      do i=1, n
        call pc_strupr( type_name_list(i) )
        lid = -1;
        if(      type_name_list(i)(1:2) == 'BX'  ) then; lid = 1
        else if( type_name_list(i)(1:2) == 'BY'  ) then; lid = 2
        else if( type_name_list(i)(1:2) == 'BZ'  ) then; lid = 3
        else if( type_name_list(i)(1:4) == 'GRAV') then; lid = 4
        else if( type_name_list(i)(1:4) == 'CENT') then; lid = 5
        else if( type_name_list(i)(1:2) == 'PP'  ) then; lid = 10
        else if( type_name_list(i)(1:2) == 'P0'  ) then; lid = 10
        else if( type_name_list(i)(1:2) == 'PX'  ) then
          lid = 10; params(1,:)=1.d0; params(2,:)=0.d0; params(3,:)=0.d0
        else if( type_name_list(i)(1:2) == 'PY'  ) then
          lid = 10; params(1,:)=0.d0; params(2,:)=1.d0; params(3,:)=0.d0
        else if( type_name_list(i)(1:2) == 'PZ'  ) then
          lid = 10; params(1,:)=0.d0; params(2,:)=0.d0; params(3,:)=1.d0
        else if( type_name_list(i)(1:2) == 'P1'  ) then; lid = 10
        else if( type_name_list(i)(1:2) == 'P2'  ) then; lid = 20
        else if( type_name_list(i)(1:2) == 'P3'  ) then; lid = 30
        else if( type_name_list(i)(1:2) == 'P4'  ) then; lid = 40
        else if( type_name_list(i)(1:2) == 'P5'  ) then; lid = 50
        else if( type_name_list(i)(1:2) == 'P6'  ) then; lid = 60
        else if( type_name_list(i)(1:1) == 'S'   ) then; lid = 100
        else
          write(ilog, *) 'Error : !DLOAD : Load  type ',type_name_list(i), ' is unknown'
          deallocate( type_name_list )
          return
        end if
        load_type(i) = lid
      end do
 
      deallocate( type_name_list )
      fstr_ctrl_get_dload = 0
 
  end function fstr_ctrl_get_dload
 
 
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_reftemp( ctrl, value )
    implicit none
    integer(kind=kint) :: ctrl
    real(kind=kreal)   :: value
    integer(kind=kint) :: fstr_ctrl_get_reftemp,rcode
 
    rcode = fstr_ctrl_get_data_ex( ctrl, 1, 'r ', value )
    fstr_ctrl_get_reftemp = rcode
 
  end function fstr_ctrl_get_reftemp
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_temperature( ctrl, irres, tstep, tintl, rtype, node_id, node_id_len, value )
    implicit none
    integer(kind=kint) :: ctrl
    integer(kind=kint) :: irres
    integer(kind=kint) :: tstep
    integer(kind=kint) :: tintl
    integer(kind=kint) :: rtype
    character(len=HECMW_NAME_LEN) :: node_id(:)
    integer(kind=kint) :: node_id_len
    real(kind=kreal),pointer :: value(:)
    integer(kind=kint) :: fstr_ctrl_get_temperature, rcode
 
    character(len=HECMW_NAME_LEN) :: data_fmt,ss
 
    irres = 0
    if( fstr_ctrl_get_param_ex( ctrl, 'READRESULT ', '# ', 0, 'I', irres )/= 0) return
    if( fstr_ctrl_get_param_ex( ctrl, 'SSTEP ',      '# ', 0, 'I', tstep )/= 0) return
    if( fstr_ctrl_get_param_ex( ctrl, 'INTERVAL ',   '# ', 0, 'I', tintl )/= 0) return
    if( fstr_ctrl_get_param_ex( ctrl, 'READTYPE ',   'STEP,TIME ', 0, 'P', rtype )/= 0) return
    if( irres > 0 ) then
      fstr_ctrl_get_temperature = 0
      return
    endif
 
    write(ss,*)  node_id_len
    write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'r '
 
    rcode = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, node_id, value )
    fstr_ctrl_get_temperature = rcode
 
  end function fstr_ctrl_get_temperature
 
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_spring( ctrl, amp, node_id, node_id_len, dof_id, value )
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp
    character(len=HECMW_NAME_LEN) :: node_id(:)
    integer(kind=kint) :: node_id_len
    integer(kind=kint),pointer :: dof_id(:)
    real(kind=kreal),pointer :: value(:)
    integer(kind=kint) :: fstr_ctrl_get_spring
 
    character(len=HECMW_NAME_LEN) :: data_fmt,ss
    write(ss,*)  node_id_len
    write( data_fmt, '(a,a,a)') 'S', trim(adjustl(ss)), 'IR '
 
    fstr_ctrl_get_spring = -1
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP ',  '# ',  0, 'S', amp )/= 0) return
    fstr_ctrl_get_spring = &
      fstr_ctrl_get_data_array_ex( ctrl, data_fmt, node_id, dof_id, value )
 
  end function fstr_ctrl_get_spring
 
 
  !----------------------------------------------------------------------
  integer function fstr_ctrl_get_userload( ctrl )
    use muload
    integer(kind=kint), intent(in)    :: ctrl
 
    character(len=256) :: fname
 
    fstr_ctrl_get_userload = -1
    if( fstr_ctrl_get_param_ex( ctrl, 'FILE ', '# ',           0,   'S',   fname )/=0 ) return
    if( fname=="" ) stop "You must define a file name before read in user-defined material"
    if( ureadload(fname)/=0 ) return
 
    fstr_ctrl_get_userload = 0
  end function fstr_ctrl_get_userload
 
end module fstr_ctrl_static