D.4.8 Output_Data_Index Procedure

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

  subroutine Output_Data_Index (Index, First, Last, Unit, Indent, Output_OPE)

    ! Input variables.

    type(Data_Index_type), intent(in) :: Index        ! Variable to be output.
    type(integer), intent(in), optional :: First      ! Extents of value data
    type(integer), intent(in), optional :: Last       !   to be output.
    type(integer), intent(in), optional :: Unit       ! Output unit.
    type(integer), intent(in), optional :: Indent     ! Indentation.
    type(logical), intent(in), optional :: Output_OPE ! Output OPE toggle.

    ! Internal variables.

    type(integer) :: Buffer_Loc                     ! Buffer location.
    type(integer) :: Buffer_Size                    ! Output buffer size.
    type(integer) :: Buffer_Skip                    ! Buffer increment.
    type(integer) :: i_global, i_local              ! Loop counters.
    type(integer) :: A_First                        ! Actual first value.
    type(integer) :: A_Last                         ! Actual last value.
    type(integer) :: A_Unit                         ! Actual output unit.
    type(logical) :: A_Output_OPE                   ! Actual output OPE toggle.
    type(integer) :: i, j, OPE                      ! Off-PE loop counters.
    type(integer) :: A_Indent                       ! Actual indentation.
    type(character,80) :: Blanks                    ! A line of blanks.
    type(character,80) :: Output_1                  ! Output buffer.
    type(character,80,1) :: Output_Buffer           ! Output buffer vector.

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

    ! Verify requirements.

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

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

    ! Set indentation.
    
    if (PRESENT(Indent)) then
      A_Indent = Indent
    else
      A_Indent = 0
    end if
    Blanks = ' '
     
    ! Output Identification Info.

    if (this_is_IO_PE) then
      write (A_Unit,100) Blanks(1:A_Indent), 'Data Index Information:'
      write (A_Unit,101) Blanks(1:A_Indent+2), 'Locus                  = ', &
                         TRIM(Locus(Index%Many_Structure)), ' of ', &
                         TRIM(Locus(Index%One_Structure))
      write (A_Unit,102) Blanks(1:A_Indent+2), 'Initialized            = ', &
                         Initialized(Index)
      write (A_Unit,103) Blanks(1:A_Indent+2), 'Dimensionality         =', &
                         Index%Dimensionality
    end if

    ! PE-dependent info.

    write (Output_1,104) Blanks(1:A_Indent+2), 'PE:', this_PE, &
                         ', NOff_PE      =', Index%NOff_PE
    call Parallel_Write (Output_1, A_Unit)

    if (PRESENT(Output_OPE)) then
      A_Output_OPE = Output_OPE
    else
      A_Output_OPE = .true.
    end if
    if (A_Output_OPE) then
      Buffer_Size = MAX(1, (SIZE(Index%Off_PE_Index) + 3)/ 4)
      call Initialize (Output_Buffer, Buffer_Size)

      if (Index%NOff_PE <= 4) then
        write (Output_Buffer,105) Blanks(1:A_Indent+2), 'PE:', this_PE, &
                                  ', Off_PE_Index =', &
                                  (Index%Off_PE_Index(OPE), &
                                  OPE = 1, MIN(Index%NOff_PE, 4))
      else
        write (Output_Buffer,105) Blanks(1:A_Indent+2), 'PE:', this_PE, &
                                  ', Off_PE_Index =', &
                                  (Index%Off_PE_Index(OPE), OPE = 1, 4), ','
        j = 2
        do OPE = 5, Index%NOff_PE, 4
          if (OPE + 4 <= Index%NOff_PE) then 
            write (Output_Buffer(j),106) Blanks(1:A_Indent+26), &
                                         (Index%Off_PE_Index(i), &
                                         i = OPE, MIN(OPE+3, Index%NOff_PE)), &
                                         ','
          else
            write (Output_Buffer(j),106) Blanks(1:A_Indent+26), &
                                         (Index%Off_PE_Index(i), &
                                         i = OPE, MIN(OPE+3, Index%NOff_PE))
          end if
          j = j+1
        end do
      end if

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

    end if

    ! Output internal structure info.

    call Output (Index%Many_Structure, A_Unit, 'Many', A_Indent+2)
    call Output (Index%One_Structure, A_Unit, 'One', A_Indent+2)
    !call Output (Index%Trace, A_Unit)
    !call Output (Index%Off_PE_Trace, A_Unit)

    ! Output internal values.

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

    ! Set up local limits in terms of global limits.

    if (PRESENT(First)) then
      A_First = First
    else
      A_First = 1
    end if
    if (PRESENT(Last)) then
      A_Last = Last
    else
      A_Last = Length_Total(Index%One_Structure)
    end if
    A_First = MAX(A_First, First_PE(Index%One_Structure))
    A_Last = MIN(A_Last, Last_PE(Index%One_Structure))

    ! Output the indices based on the dimensionality.
    
    select case (Index%Dimensionality)
    case (1)
      Buffer_Size = MAX(0, (A_Last - A_First + 1))
      call Initialize (Output_Buffer, Buffer_Size)
      if (Buffer_Size /= 0) then
        Buffer_Skip = 1
        Buffer_Loc = 1
        do i_global = A_First, A_Last
          i_local = i_global - First_PE(Index%One_Structure) + 1
          write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),107) &
            'PE:', this_PE, ', Index1(', i_global, ') =', &
            Index%Index1(i_local)
          Buffer_Loc = Buffer_Loc + Buffer_Skip
        end do
      end if
    case (2)
      Buffer_Size = MAX(0, ((SIZE(Index%Index2(1,:)) + 2) / 3) &
                    * (A_Last - A_First + 1))
      call Initialize (Output_Buffer, Buffer_Size)
      if (Buffer_Size /= 0) then
        Buffer_Skip = (SIZE(Index%Index2(1,:)) + 2) / 3
        Buffer_Loc = 1
        do i_global = A_First, A_Last
          i_local = i_global - First_PE(Index%One_Structure) + 1
          write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),107) &
            'PE:', this_PE, ', Index2(', i_global, ',:) =', &
            Index%Index2(i_local,:)
          Buffer_Loc = Buffer_Loc + Buffer_Skip
        end do
      end if
!    case (-1)
!      Buffer_Size = MAX(0, ((SIZE(Index%IndexRR(:,1)) + 2) / 3) &
!                    * (A_Last - A_First + 1))
!      call Initialize (Output_Buffer, Buffer_Size)
!      if (Buffer_Size /= 0) then
!        Buffer_Skip = (SIZE(Index%IndexRR(:,1)) + 2) / 3
!        Buffer_Loc = 1
!        do i_global = A_First, A_Last
!          i_local = i_global - First_PE(Index%Structure) + 1
!          write (Output_Buffer(Buffer_Loc:Buffer_Loc+Buffer_Skip-1),107) &
!            'PE:', this_PE, ', IndexRR(:,', i_global, ') =', &
!            Index%IndexRR(:,i_local)
!          Buffer_Loc = Buffer_Loc + Buffer_Skip
!        end do
!      end if
    end select

    ! Add indentation.

    do Buffer_loc = 1, Buffer_Size
      Output_1 = Output_Buffer(Buffer_loc)
      Output_Buffer(Buffer_loc) = Blanks(1:A_Indent) // Output_1
    end do

    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 (/, 2a, /)
101 format (5a)
102 format (2a, l2)
103 format (2a, i11)
104 format (2a, i5, a, i11, :, 4(',', i11, :))
105 format (a, a, i5, a, i11, :, 3(',', i11, :), a)
106 format (a, i11, :, 3(',', i11, :), a)
107 format (2x, a, i5, a, i11, a, i13, :, &
            2(',', i13, :), ',', /, &
            (35x, i13, :, 2(',', i13, :), ','))

    ! Verify guarantees - none.

    return
  end subroutine Output_Data_Index



Michael L. Hall