D.2.8 Gather Procedure

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

  define([GATHER_ROUTINE],[
    pushdef([TYPE], [$1])
    pushdef([DIM], [$2])
    pushdef([Gather_TYPE_DIM], expand(Gather_TYPE_DIM))

    subroutine Gather_TYPE_DIM (Output, Input, Index, Trace)

      ! Input variables.

      ! Distributed vector (bare naked vector) to be gathered.
      type(TYPE,1,np), intent(in) :: Input  
      type(integer,DIM,np), intent(in), optional :: Index ! Indirect reference 
                                                          ! indices.

      ! Input/Output variable.

      type(Trace_type), intent(inout), optional :: Trace  ! Setup information.

      ! Output variable.

      type(TYPE,DIM,np), intent(out) :: Output            ! Gathered variable.
                                                          
      ! Internal variable.                                
                                                          
      ifdef([USE_PGSLIB],[
        type(integer,DIM) :: Index_tmp           ! Index temporary.
        type(logical,DIM) :: Mask_tmp            ! Index mask temporary.
      ],[
        ifelse(DIM, [1], [], [
          type(integer) :: column                ! Loop parameter.
        ]) 
        type(integer) :: row                     ! Loop parameter.
      ]) 
  
      !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      ! Verify requirements.
  
      ! Either the Trace or the Index, or both, must be present.
      VERIFY(PRESENT(Index) .or. PRESENT(Trace),5)

      ! Initialize the Trace.

      if (PRESENT(Trace)) then
        if (.not. Initialized(Trace)) then
          VERIFY(PRESENT(Index),5)
          call Initialize (Trace, Index, SIZE(Input))
        end if
      end if

      ! Do the global gather.

      ifdef([USE_PGSLIB],[
    
        ! PGSLib parallel gather.

        if (PRESENT(Trace)) then
          call PGSLib_Gather (Output, Input, Trace%Index[]DIM,  &
                              Trace%Trace, Trace%Mask[]DIM)
        else
          ifelse(DIM, [1], [
            call Initialize (Index_tmp, SIZE(Index))
            call Initialize (Mask_tmp,  SIZE(Index))
          ], [
            call Initialize (Index_tmp, SIZE(Index,1), SIZE(Index,2))
            call Initialize (Mask_tmp,  SIZE(Index,1), SIZE(Index,2))
          ])
          Index_tmp = Index
          Mask_tmp = Index_tmp /= 0
          call PGSLib_Gather (Output, Input, Index_tmp, Mask=Mask_tmp)
          call Finalize (Index_tmp)
          call Finalize (Mask_tmp)
        end if
  
      ],[

        ! Serial gather.

        if (PRESENT(Trace)) then
          ifelse(DIM, [1], [
            do row = 1, SIZE(Output, 1)
              if (Trace%Index1(row) /= 0) then
                Output(row) = Input(Trace%Index1(row))
              end if
            end do
          ],[
            do column = 1, SIZE(Output, 2)
              do row = 1, SIZE(Output, 1)
                if (Trace%Index2(row,column) /= 0) then
                  Output(row,column) = Input(Trace%Index2(row,column))
                end if
              end do
            end do
          ])
        else
          ifelse(DIM, [1], [
            do row = 1, SIZE(Output, 1)
              if (Index(row) /= 0) then
                Output(row) = Input(Index(row))
              end if
            end do
          ],[
            do column = 1, SIZE(Output, 2)
              do row = 1, SIZE(Output, 1)
                if (Index(row,column) /= 0) then
                  Output(row,column) = Input(Index(row,column))
                end if
              end do
            end do
          ])
        end if
      ])

      ! Verify guarantees - none.
  
      return
    end subroutine Gather_TYPE_DIM
  
    popdef([TYPE])
    popdef([DIM])
    popdef([Gather_TYPE_DIM])
  ])

  forloop([Dim],[1],[2],[
    fortext([Type],[real integer logical],[
      GATHER_ROUTINE(Type, Dim)
    ])
  ])