tem_color_prop_load Subroutine

public subroutine tem_color_prop_load(me, tree, myPart, comm)

Load the color property from disk.

Arguments

Type IntentOptional Attributes Name
type(tem_color_prop_type), intent(out) :: me

Color definitions to load.
type(treelmesh_type), intent(in) :: tree

Tree to build the polynomial subresolution information for
integer, intent(in) :: myPart

Partition to load
integer, intent(in) :: comm

Communicator to use

Calls

proc~~tem_color_prop_load~~CallsGraph proc~tem_color_prop_load tem_color_prop_load aot_get_val aot_get_val proc~tem_color_prop_load->aot_get_val aot_table_close aot_table_close proc~tem_color_prop_load->aot_table_close aot_table_open aot_table_open proc~tem_color_prop_load->aot_table_open close_config close_config proc~tem_color_prop_load->close_config mpi_bcast mpi_bcast proc~tem_color_prop_load->mpi_bcast open_config_file open_config_file proc~tem_color_prop_load->open_config_file proc~tem_open tem_open proc~tem_color_prop_load->proc~tem_open proc~newunit newunit proc~tem_open->proc~newunit proc~tem_abort tem_abort proc~tem_open->proc~tem_abort proc~upper_to_lower upper_to_lower proc~tem_open->proc~upper_to_lower mpi_abort mpi_abort proc~tem_abort->mpi_abort

Source Code

  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