assign_container Subroutine

private subroutine assign_container(lhs, rhs)

Arguments

Type IntentOptional AttributesName
class(*), intent(inout) :: lhs

The variable which the container contents will be assigned to.

class(container), intent(in) :: rhs

The container variable.

Description

Transfers the contents of the container to another variable. If the other variable is another container of the same type then the contents will be transferred. If the other variable is the same type as the contents of the container (as determined by the typeguard routine provided for that concrete type extension) then it will be given the value held by the container. Otherwise, an error message will be printed and the program stopped. If compiled with gfortran then a backtrace will also be printed. In the event that the container was never set to a value, then this also constitutes an error.


Source Code

  subroutine assign_container(lhs, rhs)
    !! Author: Chris MacMackin
    !! Date: December 2015
    !!
    !! Transfers the contents of the container to another variable.
    !! If the other variable is another container of the same type
    !! then the contents will be transferred. If the other variable is
    !! the same type as the contents of the container (as determined
    !! by the [[container:typeguard]] routine provided for that 
    !! concrete type extension) then it will be given the value held by
    !! the container. Otherwise, an error message will be printed and 
    !! the program stopped. If compiled with `gfortran` then a backtrace
    !! will also be printed. In the event that the container was never
    !! set to a value, then this also constitutes an error.
    class(*), intent(inout) ::  lhs
      !! The variable which the container contents will be assigned to.
    class(container), intent(in)  ::  rhs
      !! The container variable.
    !-------------------------------------------------------------------
    select type(lhs)
      class is(container)
        if (same_type_as(lhs, rhs)) then
          if (rhs%filled) then
            lhs%storage = rhs%storage
            lhs%filled = .true.
          else if (lhs%filled) then
            deallocate(lhs%storage)
            lhs%filled = .false.
          end if
          return
        else
          write(stderr,*) "ERROR: Can not assign to a different container subclass"
#ifdef __GFORTRAN__
          call backtrace
#endif
          stop
        end if
      class default
        if (rhs%filled) then
          if (rhs%typeguard(lhs)) return
          write(stderr,*) "ERROR: Can not assign this container's contents to given variable"
#ifdef __GFORTRAN__
          call backtrace
#endif
          stop
        else
          write(stderr,*) "ERROR: Container is empty."
#ifdef __GFORTRAN__
          call backtrace
#endif
          stop
        end if
    end select
  end subroutine assign_container