fstr_ctrl_heat.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_heat
  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_heat( ctrl, dt, etime, dtmin, deltmx, itmax, eps, tpname, beta )
    implicit none
    integer(kind=kint) :: ctrl
    real(kind=kreal),pointer :: dt(:)
    real(kind=kreal),pointer :: etime(:)
    real(kind=kreal),pointer :: dtmin(:)
    real(kind=kreal),pointer :: deltmx(:)
    integer(kind=kint),pointer :: itmax(:)
    real(kind=kreal),pointer :: eps(:)
    character(len=*), intent(out) :: tpname
    integer(kind=kint) :: fstr_ctrl_get_heat
    integer(kind=kint) :: result
    real(kind=kreal) :: beta, t_beta
 
    fstr_ctrl_get_heat = -1
 
    tpname=""
    if( fstr_ctrl_get_param_ex( ctrl, 'TIMEPOINTS ',  '# ',  0, 'S', tpname )/= 0) return
 
    ! JP-7
    if( fstr_ctrl_get_data_array_ex( ctrl, 'rrrrir ', dt, etime, dtmin, deltmx, itmax, eps )/= 0) return
 
    beta = -1.0d0
    t_beta = -1.0d0
    if( fstr_ctrl_get_param_ex( ctrl, 'BETA ', '# ', 0, 'R', t_beta)/=0 ) return
    if(0.0d0 <= t_beta .and. t_beta <= 1.0d0) beta = t_beta
 
    fstr_ctrl_get_heat = 0
  end function fstr_ctrl_get_heat
 
  function fstr_ctrl_get_fixtemp( ctrl, amp, node_grp_name, node_grp_name_len, value )
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp
    character(len=HECMW_NAME_LEN) :: node_grp_name(:)
    integer(kind=kint) :: node_grp_name_len
    real(kind=kreal), pointer :: value(:)
    integer(kind=kint) :: fstr_ctrl_get_fixtemp
 
    character(len=HECMW_NAME_LEN) :: data_fmt,ss
 
    fstr_ctrl_get_fixtemp = -1
 
    ! JP-8
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP ',  '# ',          0,     'S',   amp    )/= 0) return
 
    write(ss,*)  node_grp_name_len
    write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'r '
 
    fstr_ctrl_get_fixtemp = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, node_grp_name, value )
 
  end function fstr_ctrl_get_fixtemp
 
 
  function fstr_ctrl_get_cflux( ctrl, amp, node_grp_name, node_grp_name_len, value )
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp
    character(len=HECMW_NAME_LEN) :: node_grp_name(:)
    integer(kind=kint) :: node_grp_name_len
    real(kind=kreal),pointer :: value(:)
    integer(kind=kint) :: fstr_ctrl_get_cflux
 
    character(len=HECMW_NAME_LEN) :: data_fmt,ss
 
    fstr_ctrl_get_cflux= -1
 
    ! JP-9
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP ',  '# ',          0,     'S',   amp    )/= 0) return
 
    write(ss,*)  node_grp_name_len
    write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'r '
 
    fstr_ctrl_get_cflux = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, node_grp_name, value )
 
  end function fstr_ctrl_get_cflux
 
  function fstr_ctrl_get_dflux( ctrl, amp, elem_grp_name, elem_grp_name_len, load_type, value )
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp
    character(len=HECMW_NAME_LEN) :: elem_grp_name(:)
    integer(kind=kint) :: elem_grp_name_len
    integer(kind=kint),pointer :: load_type(:)
    real(kind=kreal),pointer :: value(:)
    integer(kind=kint) :: fstr_ctrl_get_dflux
 
    integer(kind=kint), parameter :: type_name_size = 5
    integer(kind=kint) :: i, n
    character(len=HECMW_NAME_LEN) :: data_fmt,s1,s2
    character(len=type_name_size),pointer :: type_name_list(:)
    integer(kind=kint) :: rcode
    integer(kind=kint) :: lid = -1
 
    fstr_ctrl_get_dflux = -1
 
    ! JP-10
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP ',  '# ',          0,     'S',   amp    )/= 0) return
 
    write(s1,*)  elem_grp_name_len
    write(s2,*)  type_name_size
    write(data_fmt,'(a,a,a,a,a)') 'S',trim(adjustl(s1)),'S',trim(adjustl(s2)),'r '
 
    n = fstr_ctrl_get_data_line_n(ctrl)
    allocate( type_name_list(n) )
 
      rcode = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, elem_grp_name, type_name_list, value)
 
      if( rcode /= 0 ) then
        deallocate( type_name_list )
        return
      end if
 
      do i = 1, n
        lid = -1;
        call pc_strupr( type_name_list(i) )
        if(      type_name_list(i)(1:2) == 'BF'  ) then; lid = 0
        else if( type_name_list(i)(1:2) == 'S0'  ) then; lid = 1
        else if( type_name_list(i)(1:2) == 'S1'  ) then; lid = 1
        else if( type_name_list(i)(1:2) == 'S2'  ) then; lid = 2
        else if( type_name_list(i)(1:2) == 'S3'  ) then; lid = 3
        else if( type_name_list(i)(1:2) == 'S4'  ) then; lid = 4
        else if( type_name_list(i)(1:2) == 'S5'  ) then; lid = 5
        else if( type_name_list(i)(1:2) == 'S6'  ) then; lid = 6
        end if
        if( lid < 0 ) then
          write(ilog,*) 'Error : !DFLUX : 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_dflux = 0
  end function fstr_ctrl_get_dflux
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_sflux( ctrl, amp, surface_grp_name, surface_grp_name_len, value )
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp
    character(len=HECMW_NAME_LEN) :: surface_grp_name(:)
    integer(kind=kint) :: surface_grp_name_len
    real(kind=kreal),pointer :: value(:)
    integer(kind=kint) :: fstr_ctrl_get_sflux
 
    character(len=HECMW_NAME_LEN) :: data_fmt,ss
 
    fstr_ctrl_get_sflux = -1
 
    ! JP-11
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP ',  '# ',          0,     'S',   amp    )/= 0) return
 
    write(ss,*)  surface_grp_name_len
    write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'r '
 
    fstr_ctrl_get_sflux = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, surface_grp_name, value )
  end function fstr_ctrl_get_sflux
 
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_film( ctrl, amp1, amp2, elem_grp_name, elem_grp_name_len, load_type, value, sink)
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp1
    character(len=HECMW_NAME_LEN) :: amp2
    character(len=HECMW_NAME_LEN) :: elem_grp_name(:)
    integer(kind=kint) :: elem_grp_name_len
    integer(kind=kint),pointer :: load_type(:)
    real(kind=kreal),pointer :: value(:)
    real(kind=kreal),pointer :: sink(:)
    integer(kind=kint) :: fstr_ctrl_get_film
 
    integer(kind=kint),parameter :: type_name_size = 5
    integer(kind=kint) :: i, n
    character(len=HECMW_NAME_LEN) :: data_fmt,s1,s2
    character(len=type_name_size),pointer :: type_name_list(:)
    integer(kind=kint) :: lid
    integer(kind=kint) :: rcode
 
    fstr_ctrl_get_film = -1
 
    ! JP-12
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP1 ',  '# ',         0,     'S',   amp1   )/= 0) return
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP2 ',  '# ',         0,     'S',   amp2   )/= 0) return
 
    write(s1,*)  elem_grp_name_len
    write(s2,*)  type_name_size
    write(data_fmt,'(a,a,a,a,a)') 'S',trim(adjustl(s1)),'S',trim(adjustl(s2)),'Rr '
 
    n = fstr_ctrl_get_data_line_n(ctrl)
    allocate( type_name_list(n) )
 
      rcode = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, elem_grp_name, type_name_list, value, sink)
 
      if( rcode /= 0 ) then
        deallocate( type_name_list )
        return
      end if
 
      do i = 1, n
        lid = -1;
        call pc_strupr( type_name_list(i) )
        if(      type_name_list(i)(1:2) == 'F0'  ) then; lid = 1
        else if( type_name_list(i)(1:2) == 'F1'  ) then; lid = 1
        else if( type_name_list(i)(1:2) == 'F2'  ) then; lid = 2
        else if( type_name_list(i)(1:2) == 'F3'  ) then; lid = 3
        else if( type_name_list(i)(1:2) == 'F4'  ) then; lid = 4
        else if( type_name_list(i)(1:2) == 'F5'  ) then; lid = 5
        else if( type_name_list(i)(1:2) == 'F6'  ) then; lid = 6
        end if
        if( lid < 0 ) then
          write(ilog,*) 'Error : !FILM : 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_film = 0
  end function fstr_ctrl_get_film
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_sfilm( ctrl, amp1, amp2, surface_grp_name, surface_grp_name_len, value, sink)
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp1
    character(len=HECMW_NAME_LEN) :: amp2
    character(len=HECMW_NAME_LEN) :: surface_grp_name(:)
    integer(kind=kint) :: surface_grp_name_len
    real(kind=kreal),pointer :: value(:)
    real(kind=kreal),pointer :: sink(:)
    integer(kind=kint) :: fstr_ctrl_get_sfilm
 
    character(len=HECMW_NAME_LEN) :: data_fmt,ss
 
    fstr_ctrl_get_sfilm = -1
 
    ! JP-13
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP1 ',  '# ',          0,     'S',   amp1    )/= 0) return
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP2 ',  '# ',          0,     'S',   amp2    )/= 0) return
 
    write(ss,*)  surface_grp_name_len
    write(data_fmt,'(a,a,a)') 'S',trim(adjustl(ss)),'Rr '
 
    fstr_ctrl_get_sfilm = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, surface_grp_name, value, sink )
  end function fstr_ctrl_get_sfilm
 
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_radiate( ctrl, amp1, amp2, elem_grp_name, elem_grp_name_len, load_type, value, sink)
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp1
    character(len=HECMW_NAME_LEN) :: amp2
    character(len=HECMW_NAME_LEN) :: elem_grp_name(:)
    integer(kind=kint) :: elem_grp_name_len
    integer(kind=kint),pointer :: load_type(:)
    real(kind=kreal),pointer :: value(:)
    real(kind=kreal),pointer :: sink(:)
    integer(kind=kint) :: fstr_ctrl_get_radiate
 
    integer(kind=kint),parameter :: type_name_size = 5
    integer(kind=kint) :: i, n
    character(len=HECMW_NAME_LEN) :: data_fmt,s1,s2
    character(len=type_name_size),pointer :: type_name_list(:)
    integer(kind=kint) :: lid
    integer(kind=kint) :: rcode
 
    fstr_ctrl_get_radiate = -1
 
    ! JP-14
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP1 ',  '# ',         0,     'S',   amp1   )/= 0) return
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP2 ',  '# ',         0,     'S',   amp2   )/= 0) return
 
    write(s1,*)  elem_grp_name_len
    write(s2,*)  type_name_size
    write(data_fmt,'(a,a,a,a,a)') 'S',trim(adjustl(s1)),'S',trim(adjustl(s2)),'Rr '
 
    n = fstr_ctrl_get_data_line_n(ctrl)
    allocate( type_name_list(n) )
 
      rcode = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, elem_grp_name ,type_name_list, value, sink)
 
      if( rcode /= 0 ) then
        deallocate( type_name_list )
        return
      end if
 
      do i = 1, n
        lid = -1;
        call pc_strupr( type_name_list(i) )
        if(      type_name_list(i)(1:2) == 'R0'  ) then; lid = 1
        else if( type_name_list(i)(1:2) == 'R1'  ) then; lid = 1
        else if( type_name_list(i)(1:2) == 'R2'  ) then; lid = 2
        else if( type_name_list(i)(1:2) == 'R3'  ) then; lid = 3
        else if( type_name_list(i)(1:2) == 'R4'  ) then; lid = 4
        else if( type_name_list(i)(1:2) == 'R5'  ) then; lid = 5
        else if( type_name_list(i)(1:2) == 'R6'  ) then; lid = 6
        end if
        if( lid < 0 ) then
          write(ilog,*) 'Error : !RADIATE : 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_radiate = 0
  end function fstr_ctrl_get_radiate
 
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_sradiate( ctrl, amp1, amp2, surface_grp_name, surface_grp_name_len, value, sink)
    implicit none
    integer(kind=kint) :: ctrl
    character(len=HECMW_NAME_LEN) :: amp1
    character(len=HECMW_NAME_LEN) :: amp2
    character(len=HECMW_NAME_LEN) :: surface_grp_name(:)
    integer(kind=kint) :: surface_grp_name_len
    real(kind=kreal),pointer :: value(:)
    real(kind=kreal),pointer :: sink(:)
    integer(kind=kint) :: fstr_ctrl_get_sradiate
 
    character(len=HECMW_NAME_LEN) :: data_fmt
    character(len=HECMW_NAME_LEN) :: s1
 
    fstr_ctrl_get_sradiate = -1
 
    ! JP-15
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP1 ',  '# ',          0,     'S',   amp1    )/= 0) return
    if( fstr_ctrl_get_param_ex( ctrl, 'AMP2 ',  '# ',          0,     'S',   amp2    )/= 0) return
 
    write(s1,*) surface_grp_name_len;
    write(data_fmt,'(a,a,a)') 'S', trim(adjustl(s1)), 'Rr  '
 
    fstr_ctrl_get_sradiate = fstr_ctrl_get_data_array_ex( ctrl, data_fmt, surface_grp_name, value, sink )
 
  end function fstr_ctrl_get_sradiate
 
  !* ----------------------------------------------------------------------------------------------- *!
  !* ----------------------------------------------------------------------------------------------- *!
 
  function fstr_ctrl_get_weldline( ctrl, hecMESH, grp_name_len, weldline )
    use fstr_setup_util
    implicit none
    integer(kind=kint), intent(in)       :: ctrl
    type(hecmwst_local_mesh), intent(in) :: hecmesh
    integer(kind=kint), intent(in)       :: grp_name_len
    type(tweldline), intent(inout)       :: weldline
    integer(kind=kint) :: fstr_ctrl_get_weldline
 
    character(len=HECMW_NAME_LEN) :: data_fmt
    character(len=HECMW_NAME_LEN) :: s1, grp_id_name(1)
    integer :: grp_id(1)
 
    fstr_ctrl_get_weldline = -1
    if( fstr_ctrl_get_data_ex( ctrl, 1, 'RRRR ',   weldline%I, weldline%U, weldline%coe, weldline%v )/=0 ) return
    write(s1,*) grp_name_len
    write(data_fmt,'(a,a,a)') 'S', trim(adjustl(s1)), 'IRRRR  '
    if( fstr_ctrl_get_data_ex( ctrl, 2, data_fmt,  grp_id_name(1), weldline%xyz, weldline%n1, &
      weldline%n2, weldline%distol, weldline%tstart )/=0 ) return
    call elem_grp_name_to_id( hecmesh, 'WELD_LINE ', 1, grp_id_name, grp_id )
    weldline%egrpid = grp_id(1)
 
    fstr_ctrl_get_weldline = 0
  end function fstr_ctrl_get_weldline
 
  !* ----------------------------------------------------------------------------------------------- *!
end module fstr_ctrl_heat