D.3.6 Generate_Multiple_Base_Structure Procedure

The main documentation of the Generate_Multiple_Base_Structure Procedure contains additional explanation of this code listing.

  subroutine Generate_Multiple_Base_Struct (Structure_Multiple, N, &
                                            Structure_source, Locus, status)

    ! Input variables.

    type(Base_Structure_type), intent(in) :: Structure_source
    type(integer), intent(in) :: N
    type(character,*), intent(in), optional :: Locus ! Distributed location.

    ! Output variables.

    ! Base_Structure to be initialized.
    type(Base_Structure_type), intent(out) :: Structure_Multiple 
    type(Status_type), intent(out), optional :: status  ! Exit status.

    ! Internal variables.

    type(Status_type), dimension(2) :: allocate_status ! Allocation Status.
    type(Status_type) :: consolidated_status           ! Consolidated Status.
    type(integer,1) :: Length_Vector                   ! Length for each PE.

    !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    ! Verify requirements.

    VERIFY(Valid_State(Structure_source),5)        ! Structure_source is valid.

    ! Allocations and initializations.

    call Initialize (allocate_status)
    call Initialize (consolidated_status)
    call Initialize (Length_Vector, NPEs, allocate_status(1))

    ! Multiply the length vector.

    Length_Vector = N * Structure_source%Length_Vector

    ! Initialize Structure_Multiple to be a multiple of Structure_source.

    call Initialize (Structure_Multiple, Length_Vector, &
                     status=allocate_status(2))

    ! Set Locus.

    if (PRESENT(Locus)) then
      Structure_Multiple%Locus = Locus
    else
      Structure_Multiple%Locus = Structure_source%Locus
    end if

    ! Process status variables.

    consolidated_status = allocate_status
    if (PRESENT(status)) then
      WARN_IF(Error(consolidated_status), 5)
      status = consolidated_status
    else
      VERIFY(Normal(consolidated_status), 5)
    end if
    call Finalize (consolidated_status)
    call Finalize (allocate_status)

    ! Finalize variable.

    call Finalize (Length_Vector)

    ! Verify guarantees.

    VERIFY(Valid_State(Structure_Multiple),5) ! Base_Structure is now valid.

    return
  end subroutine Generate_Multiple_Base_Struct