tem_color_prop_module.f90 Source File


This file depends on

sourcefile~~tem_color_prop_module.f90~~EfferentGraph sourcefile~tem_color_prop_module.f90 tem_color_prop_module.f90 sourcefile~tem_property_module.f90 tem_property_module.f90 sourcefile~tem_color_prop_module.f90->sourcefile~tem_property_module.f90 sourcefile~tem_prophead_module.f90 tem_prophead_module.f90 sourcefile~tem_color_prop_module.f90->sourcefile~tem_prophead_module.f90 sourcefile~tem_aux_module.f90 tem_aux_module.f90 sourcefile~tem_color_prop_module.f90->sourcefile~tem_aux_module.f90 sourcefile~env_module.f90 env_module.f90 sourcefile~tem_color_prop_module.f90->sourcefile~env_module.f90 sourcefile~treelmesh_module.f90 treelmesh_module.f90 sourcefile~tem_color_prop_module.f90->sourcefile~treelmesh_module.f90 sourcefile~tem_property_module.f90->sourcefile~tem_prophead_module.f90 sourcefile~tem_property_module.f90->sourcefile~env_module.f90 sourcefile~tem_prophead_module.f90->sourcefile~env_module.f90 sourcefile~tem_aux_module.f90->sourcefile~env_module.f90 sourcefile~tem_lua_requires_module.f90 tem_lua_requires_module.f90 sourcefile~tem_aux_module.f90->sourcefile~tem_lua_requires_module.f90 sourcefile~tem_logging_module.f90 tem_logging_module.f90 sourcefile~tem_aux_module.f90->sourcefile~tem_logging_module.f90 sourcefile~tem_tools_module.f90 tem_tools_module.f90 sourcefile~tem_aux_module.f90->sourcefile~tem_tools_module.f90 sourcefile~tem_comm_env_module.f90 tem_comm_env_module.f90 sourcefile~tem_aux_module.f90->sourcefile~tem_comm_env_module.f90 sourcefile~tem_revision_module.f90 tem_revision_module.f90 sourcefile~tem_aux_module.f90->sourcefile~tem_revision_module.f90 sourcefile~treelmesh_module.f90->sourcefile~tem_property_module.f90 sourcefile~treelmesh_module.f90->sourcefile~tem_aux_module.f90 sourcefile~treelmesh_module.f90->sourcefile~env_module.f90 sourcefile~treelmesh_module.f90->sourcefile~tem_logging_module.f90 sourcefile~treelmesh_module.f90->sourcefile~tem_tools_module.f90 sourcefile~tem_global_module.f90 tem_global_module.f90 sourcefile~treelmesh_module.f90->sourcefile~tem_global_module.f90 sourcefile~tem_sparta_module.f90 tem_sparta_module.f90 sourcefile~treelmesh_module.f90->sourcefile~tem_sparta_module.f90 sourcefile~tem_topology_module.f90 tem_topology_module.f90 sourcefile~treelmesh_module.f90->sourcefile~tem_topology_module.f90 sourcefile~tem_lua_requires_module.f90->sourcefile~env_module.f90 sourcefile~tem_logging_module.f90->sourcefile~env_module.f90 sourcefile~tem_tools_module.f90->sourcefile~env_module.f90 sourcefile~tem_global_module.f90->sourcefile~tem_prophead_module.f90 sourcefile~tem_global_module.f90->sourcefile~tem_aux_module.f90 sourcefile~tem_global_module.f90->sourcefile~env_module.f90 sourcefile~tem_global_module.f90->sourcefile~tem_logging_module.f90 sourcefile~tem_sparta_module.f90->sourcefile~tem_aux_module.f90 sourcefile~tem_sparta_module.f90->sourcefile~env_module.f90 sourcefile~tem_sparta_module.f90->sourcefile~tem_logging_module.f90 sourcefile~tem_float_module.f90 tem_float_module.f90 sourcefile~tem_sparta_module.f90->sourcefile~tem_float_module.f90 sourcefile~tem_topology_module.f90->sourcefile~env_module.f90 sourcefile~tem_float_module.f90->sourcefile~env_module.f90

Files dependent on this one

sourcefile~~tem_color_prop_module.f90~~AfferentGraph sourcefile~tem_color_prop_module.f90 tem_color_prop_module.f90 sourcefile~tem_subres_prop_module.f90 tem_subres_prop_module.f90 sourcefile~tem_subres_prop_module.f90->sourcefile~tem_color_prop_module.f90

Contents


Source Code

! Copyright (c) 2014-2015, 2021 Harald Klimach <harald.klimach@dlr.de>
! Copyright (c) 2014 Simon Zimny <s.zimny@grs-sim.de>
! Copyright (c) 2014 Kannan Masilamani <kannan.masilamani@uni-siegen.de>
! Copyright (c) 2015 Jiaxing Qi <jiaxing.qi@uni-siegen.de>
! Copyright (c) 2016 Tobias Schneider <tobias1.schneider@student.uni-siegen.de>
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this
! list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ****************************************************************************** !
!> This module provides the description of colors for elements.
!!
!! Colors might be used to describe different areas in the domain, for example
!! varying material parameters.
module tem_color_prop_module
  use mpi

  use env_module,          only: labelLen, PathLen, long_k, rk, rk_mpi
  use treelmesh_module,    only: treelmesh_type
  use tem_aux_module,      only: tem_open
  use tem_prophead_module, only: tem_prophead_type
  use tem_property_module, only: tem_property_type, prp_isColored

  use aotus_module,     only: flu_state, aot_get_val, &
    &                         open_config_file, close_config
  use aot_table_module, only: aot_table_open, aot_table_close
  use aot_out_module,   only: aot_out_type, aot_out_val, aot_out_open, &
    &                         aot_out_close, aot_out_open_table,       &
    &                         aot_out_close_table

  implicit none

  private

  public :: tem_color_prop_type
  public :: tem_color_prop_load
  public :: tem_color_prop_out

  !> Number of colors to store per character.
  !!
  !! We use the ASCII character set to encode the colors.
  !! Thus, 7 colors can be stored in each of them.
  !! This leaves us with unused space of 1/8 in the files.
  !! However, it is pretty likely that we will use less then
  !! 7 colors in common settings and in this case using a single
  !! byte for all colors is the smallest packing we can use
  !! conveniently.
  integer, parameter, public :: colors_per_char = 7

  type tem_color_prop_type
    !> Pointer to treelmesh_type%global%property
    type(tem_prophead_type),  pointer :: header => null()

    !> Number of colors present in the mesh.
    integer :: nColors

    !> Number of characters required to store a bit for each color.
    integer :: nChars

    !> Array of labels identifying each of the colors.
    !! This array has a length of nColors
    character(len=LabelLen), allocatable :: color_label(:)

    !> Value to use, where the color is present.
    real(kind=rk), allocatable :: color_fill(:)

    !> Value to use, where the color is not present.
    real(kind=rk), allocatable :: color_void(:)

    !> Actual color identification.
    !!
    !! For every element with this property a bitfield is stored, to
    !! indicate which colors it has.
    !! The first index has length nChars, and the second runs over all
    !! elements with an attached color.
    !! Using characters here, to minimize the required space for color
    !! encoding of few colors.
    character, allocatable :: colored_bit(:,:)

    !> Pointer to treelmesh_type%property
    type(tem_property_type),  pointer :: property => null()

  end type tem_color_prop_type


contains


  ! **************************************************************************** !
  !> Load the color property from disk.
  subroutine tem_color_prop_load( me, tree, myPart, comm )
    ! --------------------------------------------------------------------------!
    !> Color definitions to load.
    type(tem_color_prop_type), intent(out) :: me

    !> Tree to build the polynomial subresolution information for
    type(treelmesh_type), intent(in) :: tree

    !> Partition to load
    integer, intent(in) :: myPart

    !> Communicator to use
    integer, intent(in) :: comm
    ! --------------------------------------------------------------------------!
    integer, parameter :: root = 0
    type(flu_State) :: conf
    integer :: iError
    integer :: rl
    integer :: thandle
    integer :: fUnit
    integer :: i
    integer :: iProp
    character(len=pathLen) :: headerfile
    character(len=pathLen) :: datafile
    ! --------------------------------------------------------------------------!

    me%nColors = 0

    prp_loop: do iprop=1, tree%global%nProperties
      if (tree%global%Property(iprop)%bitpos == prp_isColored) then
        me%header => tree%global%Property(iprop)
        me%property => tree%property(iprop)

        headerfile = trim(tree%global%dirname)//'colors.lua'
        datafile   = trim(tree%global%dirname)//'colors.ascii'

        if (myPart == root) then
          ! Read the header only on the root process, broadcast to all others
          ! open mesh header file
          call open_config_file( L = conf, filename = headerfile )
          call aot_get_val( L       = conf,       &
            &               key     = 'nColors',  &
            &               val     = me%nColors, &
            &               ErrCode = iError      )
        end if

        call MPI_Bcast(me%nColors, 1, MPI_INTEGER, root, comm, iError)

        ! The number of colors that can be stored per character is fixed, thus
        ! the number of characters required by a given number of colors is
        ! immediatly known.
        me%nChars = ceiling(real(me%nColors)/real(colors_per_char))

        allocate(me%color_label(me%nColors))
        allocate(me%color_fill(me%nColors))
        allocate(me%color_void(me%nColors))
        allocate(me%colored_bit(me%nChars, me%property%nElems))

        if (myPart == root) then
          ! Now read the color labels on the root process.
          call aot_table_open( L = conf, thandle = thandle, &
            &                  key = 'color_label' )
          do i=1,me%nColors
            call aot_get_val( L       = conf,              &
              &               thandle = thandle,           &
              &               pos     = i,                 &
              &               val     = me%color_label(i), &
              &               ErrCode = iError             )
          end do
          call aot_table_close( L = conf, thandle = thandle )

          ! Now read the color fill values on the root process.
          call aot_table_open( L = conf, thandle = thandle, &
            &                  key = 'color_fill' )
          do i=1,me%nColors
            call aot_get_val( L       = conf,             &
              &               thandle = thandle,          &
              &               pos     = i,                &
              &               val     = me%color_fill(i), &
              &               ErrCode = iError            )
          end do
          call aot_table_close( L = conf, thandle = thandle )

          ! Now read the color void values on the root process.
          call aot_table_open( L = conf, thandle = thandle, &
            &                  key = 'color_void' )
          do i=1,me%nColors
            call aot_get_val( L       = conf,             &
              &               thandle = thandle,          &
              &               pos     = i,                &
              &               val     = me%color_void(i), &
              &               ErrCode = iError            )
          end do
          call aot_table_close( L = conf, thandle = thandle )

          call close_config(conf)
        end if

        call MPI_Bcast( me%color_label, LabelLen*me%nColors, MPI_CHARACTER, &
          &             root, comm, iError                                  )

        call MPI_Bcast( me%color_fill, me%nColors, rk_mpi, &
          &             root, comm, iError                 )
        call MPI_Bcast( me%color_void, me%nColors, rk_mpi, &
          &             root, comm, iError                 )

        ! If there are actually colored elements on the local process,
        ! read them now.
        if (me%property%nElems > 0) then

          inquire(iolength=rl) me%colored_bit(:,1)
          call tem_open( newunit = fUnit,         &
            &            file    = datafile,      &
            &            action  = 'read',        &
            &            access  = 'stream',      &
            &            form    = 'unformatted', &
            &            status  = 'old'          )
          read(fUnit, pos=me%property%offset+1) me%colored_bit
          close(fUnit)

        end if

        EXIT prp_loop

      end if
    end do prp_loop

  end subroutine tem_color_prop_load
  ! **************************************************************************** !


  ! **************************************************************************** !
  !> Write the color property to disk.
  subroutine tem_color_prop_out( me, offset, nElems, basename, myPart, comm )
    ! --------------------------------------------------------------------------!
    !> Color definitions to load.
    type(tem_color_prop_type), intent(out) :: me

    !> Offset of the local set of elements in the global list
    integer(kind=long_k), intent(in) :: offset

    !> Local number of elements with this property
    integer, intent(in) :: nElems

    !> Name of the file, the data is stored in, will be appended with
    !! ".lua" for the header information and ".lsb" or ".msb" for the
    !! binary data. An ".ascii" extension will be used for ASCII data.
    character(len=*), intent(in) :: basename

    !> Partition to load
    integer, intent(in) :: myPart

    !> Communicator to use
    integer, intent(in) :: comm
    ! --------------------------------------------------------------------------!
    type(aot_out_type) :: conf
    integer :: locomm
    integer :: root
    integer :: rl
    integer :: fUnit
    integer :: i
    character(len=pathLen) :: headerfile
    character(len=pathLen) :: datafile
    ! --------------------------------------------------------------------------!

    root = 0

    locomm = comm

    headerfile = trim(basename)//'.lua'
    datafile   = trim(basename)//'.ascii'

    if (myPart == root) then
      ! Write the header only on the root process
      call aot_out_open( put_conf = conf, filename = headerfile )
      call aot_out_val( put_conf = conf, vname='nColors', val = me%nColors )
      call aot_out_open_table(conf, 'color_label')
      do i=1,me%nColors
        call aot_out_val( put_conf = conf, val = me%color_label(i) )
      end do
      call aot_out_close_table(conf)
      call aot_out_close(conf)
    end if

    ! If there are actually colored elements on the local process,
    ! write them now.
    ! @todo HK: replace this color output by MPI-IO.
    if (nElems > 0) then

      inquire(iolength=rl) me%colored_bit(:,1)
      call tem_open( newunit = fUnit,         &
        &            file    = datafile,      &
        &            action  = 'write',       &
        &            access  = 'direct',      &
        &            form    = 'unformatted', &
        &            recl    = rl,            &
        &            status  = 'replace'      )
      write(fUnit, rec=offset+1) me%colored_bit
      close(fUnit)

    end if

  end subroutine tem_color_prop_out
  ! **************************************************************************** !

end module tem_color_prop_module