D.8.12 Output_Collected_Array Procedure

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

  subroutine Output_Collected_Array (CA, One_First, One_Last, Unit)

    ! Input variables.

    type(Collected_Array_type), intent(in) :: CA      ! Variable to be output.
    type(integer), intent(in), optional :: One_First  ! Extents of one value 
    type(integer), intent(in), optional :: One_Last   !   data to be output.
    type(integer), intent(in), optional :: Unit       ! Output unit.

    ! Internal variables.

    type(integer) :: Buffer_Loc                     ! Buffer location.
    type(integer) :: Buffer_Size                    ! Output buffer size.
    type(integer) :: Buffer_Skip                    ! Buffer increment.
    type(integer) :: i_local, i_global              ! Loop counter.
    type(integer) :: A_One_First                    ! Actual one first value.
    type(integer) :: A_One_Last                     ! Actual one last value.
    type(integer) :: A_Unit                         ! Actual output unit.
    type(character,80) :: Name_Name                 ! Name of the CA.
    type(character,80) :: Output_1                  ! Output buffer.
    type(character,80,1) :: Output_Buffer           ! Output buffer vector.
    type(integer) :: Version_Number                 ! Version of the CA.

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

    ! Verify requirements.

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

    ! Set unit number.
    
    if (PRESENT(Unit)) then
      A_Unit = Unit
    else
      A_Unit = 6
    end if

    ! These are evaluated on all PEs -- NOT inside an IO PE block -- because
    ! they contain validity checks on CA and thus require global communication.

    Version_Number = Version(CA)
    Name_Name = Name(CA)

    ! Output Identification Info.

    if (this_is_IO_PE) then
      write (A_Unit,100) 'Collected Array Information:'
      write (A_Unit,*) ' Name                    = ', TRIM(Name_Name)
      write (A_Unit,*) ' Locus                   = ', &
                       TRIM(Locus(CA%Many_Structure)), ' of ', &
                       TRIM(Locus(CA%One_Structure))
      write (A_Unit,*) ' Initialized             = ', Initialized(CA)
      write (A_Unit,*) ' Version                 = ', Version_Number
      write (A_Unit,*) ' Dimensionality          = ', CA%Dimensionality
      write (A_Unit,*) ' A_Dimensionality        = ', CA%A_Dimensionality
    end if

    ! PE-dependent info.

    write (Output_1,101) 'PE:', this_PE, &
                         ', Dimensions    =', CA%Dimensions
    call Parallel_Write (Output_1, A_Unit)

    ! Set up actual limit values for pass-through.

    if (PRESENT(One_First)) then
      A_One_First = One_First
    else
      A_One_First = 1
    end if
    if (PRESENT(One_Last)) then
      A_One_Last = One_Last
    else
      A_One_Last = Length_Total(CA%One_Structure)
    end if
    A_One_First = MAX(A_One_First, First_PE(CA%One_Structure))
    A_One_Last = MIN(A_One_Last, Last_PE(CA%One_Structure))

    ! Output internal structure info.

    call Output (CA%Many_of_One_Index, A_One_First, A_One_Last, A_Unit, &
                 Indent=2)

    ! Output internal values.

    if (this_is_IO_PE) then
      write (A_Unit,100) '  Internal Values:'
    end if

    ! Output the values based on the dimensionality.

    select case (CA%Many_of_One_Index%Dimensionality)

    ! Vector index.

    case (1)

      select case (CA%Dimensionality)
      case (1)
        Buffer_Size = MAX(0, (A_One_Last - A_One_First + 1))
        call Initialize (Output_Buffer, Buffer_Size)
        if (Buffer_Size /= 0) then
          Buffer_Skip = 1
          Buffer_Loc = 1
          do i_global = A_One_First, A_One_Last
            i_local = i_global - First_PE(CA%One_Structure) + 1
            write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),102) &
              'PE:', this_PE, ', Values1(', i_global, ') =', &
              CA%Values1(i_local)
            Buffer_Loc = Buffer_Loc + Buffer_Skip
          end do
        end if
      case (2)
        Buffer_Size = MAX(0, ((SIZE(CA%Values2(:,1)) + 2) / 3) &
                      * (A_One_Last - A_One_First + 1))
        call Initialize (Output_Buffer, Buffer_Size)
        if (Buffer_Size /= 0) then
          Buffer_Skip = (SIZE(CA%Values2(:,1)) + 2) / 3
          Buffer_Loc = 1
          do i_global = A_One_First, A_One_Last
            i_local = i_global - First_PE(CA%One_Structure) + 1
            write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),102) &
              'PE:', this_PE, ', Values2(:,', i_global, ') =', &
              CA%Values2(:,i_local)
            Buffer_Loc = Buffer_Loc + Buffer_Skip
          end do
        end if
      case (3)
        Buffer_Size = MAX(0, ((SIZE(CA%Values3(:,:,1)) + 2) / 3) &
                      * (A_One_Last - A_One_First + 1))
        call Initialize (Output_Buffer, Buffer_Size)
        if (Buffer_Size /= 0) then
          Buffer_Skip = (SIZE(CA%Values3(:,:,1)) + 2) / 3
          Buffer_Loc = 1
          do i_global = A_One_First, A_One_Last
            i_local = i_global - First_PE(CA%One_Structure) + 1
            write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),102) &
              'PE:', this_PE, ', Values3(:,:,', i_global, ') =', &
              CA%Values3(:,:,i_local)
            Buffer_Loc = Buffer_Loc + Buffer_Skip
          end do
        end if
      case (4)
        Buffer_Size = MAX(0, ((SIZE(CA%Values4(:,:,:,1)) + 2) / 3) &
                      * (A_One_Last - A_One_First + 1))
        call Initialize (Output_Buffer, Buffer_Size)
        if (Buffer_Size /= 0) then
          Buffer_Skip = (SIZE(CA%Values4(:,:,:,1)) + 2) / 3
          Buffer_Loc = 1
          do i_global = A_One_First, A_One_Last
            i_local = i_global - First_PE(CA%One_Structure) + 1
            write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),102) &
              'PE:', this_PE, ', Values4(:,:,:,', i_global, ') =', &
              CA%Values4(:,:,:,i_local)
            Buffer_Loc = Buffer_Loc + Buffer_Skip
          end do
        end if
!      case (-1)
!        Buffer_Size = MAX(0, ((SIZE(CA%ValuesRR(:,1)) + 2) / 3) &
!                      * (A_One_Last - A_One_First + 1))
!        call Initialize (Output_Buffer, Buffer_Size)
!        if (Buffer_Size /= 0) then
!          Buffer_Skip = (SIZE(CA%ValuesRR(:,1)) + 2) / 3
!          Buffer_Loc = 1
!          do i_global = A_One_First, A_One_Last
!            i_local = i_global - First_PE(CA%One_Structure) + 1
!            write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),102) &
!              'PE:', this_PE, ', ValuesRR(:,', i_global, ') =', &
!              CA%ValuesRR(:,i_local)
!            Buffer_Loc = Buffer_Loc + Buffer_Skip
!          end do
!        end if
      end select

    ! Array index.

    case (2)

      select case (CA%Dimensionality)
      case (1)
        Buffer_Size = MAX(0, (A_One_Last - A_One_First + 1))
        call Initialize (Output_Buffer, Buffer_Size)
        if (Buffer_Size /= 0) then
          Buffer_Skip = 1
          Buffer_Loc = 1
          do i_global = A_One_First, A_One_Last
            i_local = i_global - First_PE(CA%One_Structure) + 1
            write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),102) &
              'PE:', this_PE, ', Values2(', i_global, ',:) =', &
              CA%Values2(i_local,:)
            Buffer_Loc = Buffer_Loc + Buffer_Skip
          end do
        end if
      case (2)
        Buffer_Size = MAX(0, ((SIZE(CA%Values3(:,1,:)) + 2) / 3) &
                      * (A_One_Last - A_One_First + 1))
        call Initialize (Output_Buffer, Buffer_Size)
        if (Buffer_Size /= 0) then
          Buffer_Skip = (SIZE(CA%Values3(:,1,:)) + 2) / 3
          Buffer_Loc = 1
          do i_global = A_One_First, A_One_Last
            i_local = i_global - First_PE(CA%One_Structure) + 1
            write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),102) &
              'PE:', this_PE, ', Values3(:,', i_global, ',:) =', &
              CA%Values3(:,i_local,:)
            Buffer_Loc = Buffer_Loc + Buffer_Skip
          end do
        end if
      case (3)
        Buffer_Size = MAX(0, ((SIZE(CA%Values4(:,:,1,:)) + 2) / 3) &
                      * (A_One_Last - A_One_First + 1))
        call Initialize (Output_Buffer, Buffer_Size)
        if (Buffer_Size /= 0) then
          Buffer_Skip = (SIZE(CA%Values4(:,:,1,:)) + 2) / 3
          Buffer_Loc = 1
          do i_global = A_One_First, A_One_Last
            i_local = i_global - First_PE(CA%One_Structure) + 1
            write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),102) &
              'PE:', this_PE, ', Values4(:,:,', i_global, ',:) =', &
              CA%Values4(:,:,i_local,:)
            Buffer_Loc = Buffer_Loc + Buffer_Skip
          end do
        end if
      case (4)
        Buffer_Size = MAX(0, ((SIZE(CA%Values5(:,:,:,1,:)) + 2) / 3) &
                      * (A_One_Last - A_One_First + 1))
        call Initialize (Output_Buffer, Buffer_Size)
        if (Buffer_Size /= 0) then
          Buffer_Skip = (SIZE(CA%Values5(:,:,:,1,:)) + 2) / 3
          Buffer_Loc = 1
          do i_global = A_One_First, A_One_Last
            i_local = i_global - First_PE(CA%One_Structure) + 1
            write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),102) &
              'PE:', this_PE, ', Values5(:,:,:,', i_global, ',:) =', &
              CA%Values5(:,:,:,i_local,:)
            Buffer_Loc = Buffer_Loc + Buffer_Skip
          end do
        end if
!      case (-1)
!        Buffer_Size = MAX(0, ((SIZE(CA%ValuesRR(:,1)) + 2) / 3) &
!                      * (A_One_Last - A_One_First + 1))
!        call Initialize (Output_Buffer, Buffer_Size)
!        if (Buffer_Size /= 0) then
!          Buffer_Skip = (SIZE(CA%ValuesRR(:,1)) + 2) / 3
!          Buffer_Loc = 1
!          do i_global = A_One_First, A_One_Last
!            i_local = i_global - First_PE(CA%One_Structure) + 1
!            write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),102) &
!              'PE:', this_PE, ', ValuesRR(:,', i_global, ',:) =', &
!              CA%ValuesRR(:,i_local)
!            Buffer_Loc = Buffer_Loc + Buffer_Skip
!          end do
!        end if
      end select

    end select

    call Parallel_Write (Output_Buffer, A_Unit)
    call Finalize (Output_Buffer)

    ! Format statements. With these formats, this should work up to
    ! (10^6 - 1) PEs.

100 format (/, a, /)
101 format (2x, a, i5, a, i9, :, 4(',', i9, :))
102 format (2x, a, i5, a, i11, a, 1p, e13.5e3, :, &
            2(',', e13.5e3, :), ',', /, &
            (38x, e13.5e3, :, 2(',', e13.5e3, :), ','))

    ! Verify guarantees - none.

    return
  end subroutine Output_Collected_Array



Michael L. Hall