hecmw_result_f.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 hecmw_result
  use hecmw_util
  use hecmw_etype
  implicit none
 
  private
  public :: hecmwst_result_data
  public :: hecmw_result_dtype_node
  public :: hecmw_result_dtype_elem
  public :: hecmw_result_dtype_global
  public :: hecmw_nullify_result_data
  public :: hecmw_result_copy_c2f
  public :: hecmw_result_copy_f2c
  public :: hecmw_result_init
  public :: hecmw_result_add
  public :: hecmw_result_write_by_name
  public :: hecmw_result_write_st_by_name
  public :: hecmw_result_write_by_addfname
  public :: hecmw_result_finalize
  public :: hecmw_result_free
  public :: hecmw_result_read_by_name
  public :: hecmw_result_checkfile_by_name
  private :: put_node_component
  private :: put_elem_component
  private :: refine_result
  private :: get_node_component
  private :: get_elem_component
 
  type hecmwst_result_data
    integer(kind=kint) :: ng_component
    integer(kind=kint) :: nn_component
    integer(kind=kint) :: ne_component
    integer(kind=kint),pointer :: ng_dof(:)
    integer(kind=kint),pointer :: nn_dof(:)
    integer(kind=kint),pointer :: ne_dof(:)
    character(len=HECMW_NAME_LEN),pointer :: global_label(:)
    character(len=HECMW_NAME_LEN),pointer :: node_label(:)
    character(len=HECMW_NAME_LEN),pointer :: elem_label(:)
    real(kind=kreal),pointer :: global_val_item(:)
    real(kind=kreal),pointer :: node_val_item(:)
    real(kind=kreal),pointer :: elem_val_item(:)
  end type hecmwst_result_data
 
  ! constants defined in hecmw_result_io.h
  integer(kind=kint), parameter :: hecmw_result_dtype_node   = 1
  integer(kind=kint), parameter :: hecmw_result_dtype_elem   = 2
  integer(kind=kint), parameter :: hecmw_result_dtype_global = 3
 
  interface
    subroutine hecmw_result_copy_f2c_set_if_c(sname, vname, src, ierr, len_s, len_v) &
        bind(c,name='hecmw_result_copy_f2c_set_if')
      use iso_c_binding
      type(c_ptr), value :: sname, vname
      type(c_ptr), value :: src
      integer(c_int) :: ierr
      integer(c_int), value :: len_s, len_v
    end subroutine hecmw_result_copy_f2c_set_if_c
    subroutine hecmw_result_write_st_init_if(ierr) &
        bind(c,name='hecmw_result_write_st_init_if')
      use iso_c_binding
      integer(c_int) :: ierr
    end subroutine hecmw_result_write_st_init_if
    subroutine hecmw_result_write_st_finalize_if(ierr) &
        bind(c,name='hecmw_result_write_st_finalize_if')
      use iso_c_binding
      integer(c_int) :: ierr
    end subroutine hecmw_result_write_st_finalize_if
    subroutine hecmw_result_write_st_by_name_if_c(name_ID, ierr, len) &
        bind(c,name='hecmw_result_write_st_by_name_if')
      use iso_c_binding
      type(c_ptr), value :: name_ID
      integer(c_int) :: ierr
      integer(c_int), value :: len
    end subroutine hecmw_result_write_st_by_name_if_c
 
    subroutine hecmw_result_copy_c2f_set_if_c(sname, vname, dst, ierr, len_s, len_v) &
        bind(c,name='hecmw_result_copy_c2f_set_if')
      use iso_c_binding
      type(c_ptr), value :: sname, vname
      type(c_ptr), value :: dst
      integer(c_int) :: ierr
      integer(c_int), value :: len_s, len_v
    end subroutine hecmw_result_copy_c2f_set_if_c
    subroutine hecmw_result_read_by_name_if_c(name_ID, i_step, n_node, n_elem, ierr, len) &
        bind(c,name='hecmw_result_read_by_name_if')
      use iso_c_binding
      type(c_ptr), value :: name_id
      integer(c_int) :: i_step, n_node, n_elem, ierr
      integer(c_int), value :: len
    end subroutine hecmw_result_read_by_name_if_c
    subroutine hecmw_result_read_finalize_if(ierr) &
        bind(c,name='hecmw_result_read_finalize_if')
      use iso_c_binding
      integer(c_int) :: ierr
    end subroutine hecmw_result_read_finalize_if
  end interface
 
contains
 
  subroutine hecmw_result_copy_f2c_set_if(sname, vname, src, ierr)
    use iso_c_binding
    character(len=*), target :: sname,vname
    type(*), dimension(..), target :: src
    integer(c_int) :: ierr
    call hecmw_result_copy_f2c_set_if_c(c_loc(sname), c_loc(vname), c_loc(src), ierr, len(sname), len(vname))
  end subroutine hecmw_result_copy_f2c_set_if
 
  subroutine hecmw_result_write_st_by_name_if(name_ID, ierr)
    use iso_c_binding
    character(len=*), target :: name_ID
    integer(c_int) :: ierr
    call hecmw_result_write_st_by_name_if_c(c_loc(name_id), ierr, len(name_id))
  end subroutine hecmw_result_write_st_by_name_if
 
  subroutine hecmw_result_copy_c2f_set_if(sname, vname, dst, ierr)
    use iso_c_binding
    character(len=*), target :: sname,vname
    type(*), dimension(..), target :: dst
    integer(c_int) :: ierr
    call hecmw_result_copy_c2f_set_if_c(c_loc(sname), c_loc(vname), c_loc(dst), ierr, len(sname), len(vname))
  end subroutine hecmw_result_copy_c2f_set_if
 
  subroutine hecmw_result_read_by_name_if(name_ID, i_step, n_node, n_elem, ierr)
    use iso_c_binding
    character(len=*), target :: name_ID
    integer(c_int) :: i_step, n_node, n_elem, ierr
    call hecmw_result_read_by_name_if_c(c_loc(name_id), i_step, n_node, n_elem, ierr, len(name_id))
  end subroutine hecmw_result_read_by_name_if
 
 
 
  !C=============================================================================
  !C nullify pointer
  !C=============================================================================
 
  subroutine hecmw_nullify_result_data( P )
    type( hecmwst_result_data ) :: p
    nullify( p%ng_dof )
    nullify( p%nn_dof )
    nullify( p%ne_dof )
    nullify( p%global_label )
    nullify( p%node_label )
    nullify( p%elem_label )
    nullify( p%global_val_item )
    nullify( p%node_val_item )
    nullify( p%elem_val_item )
  end subroutine hecmw_nullify_result_data
 
  !C=============================================================================
  !C Write result data to file
  !C=============================================================================
 
  subroutine hecmw_result_init(hecMESH, i_step, header, comment)
    type(hecmwst_local_mesh):: hecmesh
    integer(kind=kint) :: nnode, nelem, i_step, ierr
    character(len=HECMW_HEADER_LEN) :: header
    character(len=HECMW_MSG_LEN) :: comment
 
    nnode = hecmesh%n_node
    nelem = hecmesh%n_elem
 
    call hecmw_result_init_if(nnode, nelem, hecmesh%global_node_ID, hecmesh%global_elem_ID, &
        hecmesh%n_elem_type, hecmesh%elem_type_index, hecmesh%elem_type_item, &
        i_step, header, comment, ierr)
 
    if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
  end subroutine hecmw_result_init
 
 
  subroutine hecmw_result_add(dtype, n_dof, label, data)
    integer(kind=kint) :: dtype, n_dof, ierr
    character(len=HECMW_NAME_LEN) :: label
    real(kind=kreal) :: data(:)
 
    call hecmw_result_add_if(dtype, n_dof, label, data, ierr)
 
    if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
  end subroutine hecmw_result_add
 
 
  subroutine hecmw_result_write_by_name(name_ID)
    integer(kind=kint) :: ierr
    character(len=HECMW_NAME_LEN) :: name_id
 
    call hecmw_result_write_by_name_if(name_id, ierr)
    if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
  end subroutine hecmw_result_write_by_name
 
 
  subroutine hecmw_result_finalize()
    integer(kind=kint) :: ierr
 
    call hecmw_result_finalize_if(ierr)
    if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
  end subroutine hecmw_result_finalize
 
 
  subroutine hecmw_result_write_st_by_name(name_ID, result_data)
    integer(kind=kint) :: ierr
    type(hecmwst_result_data):: result_data
    character(len=HECMW_NAME_LEN):: name_id
 
    call hecmw_result_write_st_init_if(ierr)
    if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
    call hecmw_result_copy_f2c(result_data, ierr)
    if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
    call hecmw_result_write_st_by_name_if(name_id, ierr)
    if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
    call hecmw_result_write_st_finalize_if(ierr)
    if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
  end subroutine hecmw_result_write_st_by_name
 
 
  subroutine hecmw_result_write_by_addfname(name_ID, addfname)
    integer(kind=kint) :: ierr
    character(len=HECMW_NAME_LEN) :: name_id, addfname
 
    call hecmw_result_write_by_addfname_if(name_id, addfname, ierr)
    if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
  end subroutine hecmw_result_write_by_addfname
 
 
  subroutine  hecmw_result_copy_f2c( result_data, ierr )
    type(hecmwst_result_data), intent(in)    :: result_data
    integer(kind=kint),        intent(inout) :: ierr
 
    call  put_global_component( result_data, ierr )
    if( ierr /= 0 )  return
    call  put_node_component( result_data, ierr )
    if( ierr /= 0 )  return
    call  put_elem_component( result_data, ierr )
    if( ierr /= 0 )  return
  end subroutine  hecmw_result_copy_f2c
 
 
  subroutine  put_global_component( result_data, ierr )
    type(hecmwst_result_data), intent(in)    :: result_data
    integer(kind=kint),        intent(inout) :: ierr
    character(len=HECMW_NAME_LEN) :: sname,vname
 
    sname = "hecmwST_result_data"
 
    vname = "ng_component"
    call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%ng_component, ierr )
    if( ierr /= 0 )  return
 
    if( result_data%ng_component /= 0 )  then
      vname = "ng_dof"
      call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%ng_dof, ierr )
      if( ierr /= 0 )  return
 
      vname = "global_label"
      call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%global_label, ierr )
      if( ierr /= 0 )  return
 
      vname = "global_val_item"
      call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%global_val_item, ierr )
      if( ierr /= 0 )  return
    endif
  end subroutine  put_global_component
 
  subroutine  put_node_component( result_data, ierr )
    type(hecmwst_result_data), intent(in)    :: result_data
    integer(kind=kint),        intent(inout) :: ierr
    character(len=HECMW_NAME_LEN) :: sname,vname
 
    sname = "hecmwST_result_data"
 
    vname = "nn_component"
    call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%nn_component, ierr )
    if( ierr /= 0 )  return
 
    if( result_data%nn_component /= 0 )  then
      vname = "nn_dof"
      call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%nn_dof, ierr )
      if( ierr /= 0 )  return
 
      vname = "node_label"
      call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%node_label, ierr )
      if( ierr /= 0 )  return
 
      vname = "node_val_item"
      call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%node_val_item, ierr )
      if( ierr /= 0 )  return
    endif
  end subroutine  put_node_component
 
  subroutine  put_elem_component( result_data, ierr )
    type(hecmwst_result_data), intent(in)    :: result_data
    integer(kind=kint),        intent(inout) :: ierr
    character(len=HECMW_NAME_LEN) :: sname,vname
 
    sname = "hecmwST_result_data"
 
    vname = "ne_component"
    call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%ne_component, ierr )
    if( ierr /= 0 )  return
 
    if( result_data%ne_component /= 0 )  then
      vname = "ne_dof"
      call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%ne_dof, ierr )
      if( ierr /= 0 )  return
 
      vname = "elem_label"
      call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%elem_label, ierr )
      if( ierr /= 0 )  return
 
      vname = "elem_val_item"
      call  hecmw_result_copy_f2c_set_if( sname, vname, result_data%elem_val_item, ierr )
      if( ierr /= 0 )  return
    endif
  end subroutine  put_elem_component
 
  !C=============================================================================
  !C Read result data from file
  !C=============================================================================
 
  subroutine hecmw_result_checkfile_by_name(name_ID, i_step, ierr)
    character(len=HECMW_NAME_LEN), intent(in) :: name_id
    integer(kind=kint), intent(in) :: i_step
    integer(kind=kint), intent(out) :: ierr
 
    call hecmw_result_checkfile_by_name_if(name_id, i_step, ierr)
  end subroutine hecmw_result_checkfile_by_name
 
 
  subroutine hecmw_result_read_by_name(hecMESH, name_ID, i_step, result)
    type(hecmwst_local_mesh), intent(in) :: hecmesh
    character(len=HECMW_NAME_LEN), intent(in) :: name_id
    integer(kind=kint), intent(in) :: i_step
    type(hecmwst_result_data), intent(inout) :: result
    integer(kind=kint) :: n_node, n_elem, ierr
 
    call hecmw_result_read_by_name_if(name_id, i_step, n_node, n_elem, ierr)
    if(ierr /=0) call hecmw_abort(hecmw_comm_get_comm())
 
    call hecmw_result_copy_c2f(result, n_node, n_elem, ierr)
    if(ierr /=0) call hecmw_abort(hecmw_comm_get_comm())
 
    call hecmw_result_read_finalize_if(ierr)
    if(ierr /=0) call hecmw_abort(hecmw_comm_get_comm())
 
    call refine_result(hecmesh, n_node, result, ierr)
    if(ierr /=0) call hecmw_abort(hecmw_comm_get_comm())
  end subroutine hecmw_result_read_by_name
 
 
  subroutine refine_result(hecMESH, n_node, result, ierr)
    type(hecmwst_local_mesh), intent(in) :: hecmesh
    integer(kind=kint), intent(in) :: n_node
    type(hecmwst_result_data), intent(inout) :: result
    integer(kind=kint), intent(out) :: ierr
    real(kind=kreal), pointer :: tmp_val(:)
    integer(kind=kint) :: iref, i, j, k, is, ie, js, je, i0
    integer(kind=kint) :: jj, j0, nn_comp_tot, nn, n_node_ref
    ierr = 0
    if(n_node == hecmesh%n_node) return
    if(n_node > hecmesh%n_node) then
      write(*,*) 'ERROR: result needs to be coarsened; not implemented yet'
      ierr = 1
      return
    else
      !write(0,*) 'DEBUG: result needs to be refined'
      nn_comp_tot = 0
      do i = 1, result%nn_component
        nn_comp_tot = nn_comp_tot + result%nn_dof(i)
      enddo
      do iref = 1, hecmesh%n_refine
        is = hecmesh%refine_origin%index(iref-1)
        ie = hecmesh%refine_origin%index(iref)
        n_node_ref = ie - is
        if(n_node >= n_node_ref) cycle
        !write(0,*) 'DEBUG: start refining result; step=',iref
        allocate(tmp_val(n_node_ref * nn_comp_tot))
        tmp_val = 0.d0
        do i = 1, n_node_ref
          js = hecmesh%refine_origin%item_index(is+i-1)
          je = hecmesh%refine_origin%item_index(is+i)
          nn = je - js
          i0 = (i-1)*nn_comp_tot
          do j = js+1, je
            jj = hecmesh%refine_origin%item_item(j)
            j0 = (jj-1)*nn_comp_tot
            do k = 1, nn_comp_tot
              tmp_val(i0+k) = tmp_val(i0+k) + result%node_val_item(j0+k) / nn
            enddo
          enddo
        enddo
        deallocate(result%node_val_item)
        result%node_val_item => tmp_val
        !write(0,*) 'DEBUG: end refining result; step=',iref
      enddo
      !write(0,*) 'DEBUG: refining result done'
    endif
  end subroutine refine_result
 
 
  subroutine hecmw_result_copy_c2f(result, n_node, n_elem, ierr)
    integer(kind=kint) :: n_node, n_elem, ierr
    type(hecmwst_result_data) :: result
 
    call get_global_component(result, n_node, ierr)
    if(ierr /= 0) return
    call get_node_component(result, n_node, ierr)
    if(ierr /= 0) return
    call get_elem_component(result, n_elem, ierr)
    if(ierr /= 0) return
  end subroutine hecmw_result_copy_c2f
 
 
  subroutine get_global_component(result, n_global, ierr)
    integer(kind=kint) :: n_global, ierr
    type(hecmwst_result_data) :: result
    character(len=HECMW_NAME_LEN) :: sname,vname
 
    sname = 'hecmwST_result_data'
 
    vname = 'ng_component'
    call hecmw_result_copy_c2f_set_if(sname, vname, result%ng_component, ierr)
    if(ierr /= 0) return
 
    if(result%ng_component > 0) then
      vname = 'ng_dof'
      allocate(result%ng_dof(result%ng_component))
      call hecmw_result_copy_c2f_set_if(sname, vname, result%ng_dof, ierr)
      if(ierr /= 0) return
 
      vname = 'global_label'
      allocate(result%global_label(result%ng_component))
      call hecmw_result_copy_c2f_set_if(sname, vname, result%global_label, ierr)
      if(ierr /= 0) return
 
      vname = 'global_val_item'
      allocate(result%global_val_item(sum(result%ng_dof)*n_global))
      call hecmw_result_copy_c2f_set_if(sname, vname, result%global_val_item, ierr)
      if(ierr /= 0) return
    endif
  end subroutine get_global_component
 
 
  subroutine get_node_component(result, n_node, ierr)
    integer(kind=kint) :: n_node, ierr
    type(hecmwst_result_data) :: result
    character(len=HECMW_NAME_LEN) :: sname,vname
 
    sname = 'hecmwST_result_data'
 
    vname = 'nn_component'
    call hecmw_result_copy_c2f_set_if(sname, vname, result%nn_component, ierr)
    if(ierr /= 0) return
 
    if(result%nn_component > 0) then
      vname = 'nn_dof'
      allocate(result%nn_dof(result%nn_component))
      call hecmw_result_copy_c2f_set_if(sname, vname, result%nn_dof, ierr)
      if(ierr /= 0) return
 
      vname = 'node_label'
      allocate(result%node_label(result%nn_component))
      call hecmw_result_copy_c2f_set_if(sname, vname, result%node_label, ierr)
      if(ierr /= 0) return
 
      vname = 'node_val_item'
      allocate(result%node_val_item(sum(result%nn_dof)*n_node))
      call hecmw_result_copy_c2f_set_if(sname, vname, result%node_val_item, ierr)
      if(ierr /= 0) return
    endif
  end subroutine get_node_component
 
 
  subroutine get_elem_component(result, n_elem, ierr)
    integer(kind=kint) :: n_elem, ierr
    type(hecmwst_result_data) :: result
    character(len=HECMW_NAME_LEN) :: sname,vname
 
    sname = 'hecmwST_result_data'
 
    vname = 'ne_component'
    call hecmw_result_copy_c2f_set_if(sname, vname, result%ne_component, ierr)
    if(ierr /= 0) return
 
    if(result%ne_component > 0) then
      vname = 'ne_dof'
      allocate(result%ne_dof(result%ne_component))
      call hecmw_result_copy_c2f_set_if(sname, vname, result%ne_dof, ierr)
      if(ierr /= 0) return
 
      vname = 'elem_label'
      allocate(result%elem_label(result%ne_component))
      call hecmw_result_copy_c2f_set_if(sname, vname, result%elem_label, ierr)
      if(ierr /= 0) return
 
      vname = 'elem_val_item'
      allocate(result%elem_val_item(sum(result%ne_dof)*n_elem))
      call hecmw_result_copy_c2f_set_if(sname, vname, result%elem_val_item, ierr)
      if(ierr /= 0) return
    endif
  end subroutine get_elem_component
 
 
  subroutine  hecmw_result_free( result_data )
    type(hecmwst_result_data), intent(inout) :: result_data
    integer(kind=kint)                       :: ierr
 
    ierr = 0
 
    if( associated( result_data%ng_dof ) )  then
      deallocate( result_data%ng_dof, stat=ierr )
      if( ierr /= 0 )  then
        print *, "Error: Deallocation error"
        call  hecmw_abort( hecmw_comm_get_comm( ) )
      endif
    endif
 
    if( associated( result_data%global_label ) )  then
      deallocate( result_data%global_label, stat=ierr )
      if( ierr /= 0 )  then
        print *, "Error: Deallocation error"
        call  hecmw_abort( hecmw_comm_get_comm( ) )
      endif
    endif
 
    if( associated( result_data%global_val_item ) )  then
      deallocate( result_data%global_val_item, stat=ierr )
      if( ierr /= 0 )  then
        print *, "Error: Deallocation error"
        call  hecmw_abort( hecmw_comm_get_comm( ) )
      endif
    endif
 
    if( associated( result_data%nn_dof ) )  then
      deallocate( result_data%nn_dof, stat=ierr )
      if( ierr /= 0 )  then
        print *, "Error: Deallocation error"
        call  hecmw_abort( hecmw_comm_get_comm( ) )
      endif
    endif
 
    if( associated( result_data%node_label ) )  then
      deallocate( result_data%node_label, stat=ierr )
      if( ierr /= 0 )  then
        print *, "Error: Deallocation error"
        call  hecmw_abort( hecmw_comm_get_comm( ) )
      endif
    endif
 
    if( associated( result_data%node_val_item ) )  then
      deallocate( result_data%node_val_item, stat=ierr )
      if( ierr /= 0 )  then
        print *, "Error: Deallocation error"
        call  hecmw_abort( hecmw_comm_get_comm( ) )
      endif
    endif
 
    if( associated( result_data%ne_dof ) )  then
      deallocate( result_data%ne_dof, stat=ierr )
      if ( ierr /= 0 )  then
        print *, "Error: Deallocation error"
        call  hecmw_abort( hecmw_comm_get_comm( ) )
      endif
    endif
 
    if( associated( result_data%elem_label ) )  then
      deallocate( result_data%elem_label, stat=ierr )
      if( ierr /= 0 )  then
        print *, "Error: Deallocation error"
        call  hecmw_abort( hecmw_comm_get_comm( ) )
      endif
    endif
 
    if( associated( result_data%elem_val_item ) )  then
      deallocate( result_data%elem_val_item, stat=ierr )
      if( ierr /= 0 )  then
        print *, "Error: Deallocation error"
        call  hecmw_abort( hecmw_comm_get_comm( ) )
      endif
    endif
  end subroutine  hecmw_result_free
 
end module hecmw_result