program packer_prb
!
!*******************************************************************************
!
!! PACKER_PRB calls the PACKER tests.
!
  implicit none
!
  call timestamp ( )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'PACKER_PRB'
  write ( *, '(a)' ) '  Tests for the PACKER library.'
  write ( *, '(a)' ) ' '

  call test01
  call test02
  call test03
  call test04
  call test05

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'PACKER_PRB'
  write ( *, '(a)' ) '  Normal end of execution.'

  stop
end
subroutine test01
!
!*******************************************************************************
!
!! TEST01 tests UNPACK_TO_PACK.
!
  implicit none
!
  integer, parameter :: maxsize = 25
  integer, parameter :: rank = 2
!
  real a(maxsize)
  integer dim(rank)
  integer i
  integer ihi
  integer j
  integer k
  integer maxdim(rank)
  integer size
  integer size2
!
  a(1:maxsize) = 0.0E+00

  dim(1:2) = (/ 3, 3 /)
  maxdim(1:2) = (/ 5, 4 /)

  do i = 1, maxdim(1)
    do j = 1, maxdim(2)
      k = ( j - 1 ) * maxdim(1) + i
      if ( i <= dim(1) .and. j <= dim(2) ) then
        a(k) = real ( 10 * i + j )
      end if
    end do
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST01'
  write ( *, '(a)' ) '  UNPACK_TO_PACK converts an unpacked array with'
  write ( *, '(a)' ) '  unused intermediate space to a packed array.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Original unpacked array, as a 1D array:'
  write ( *, '(a)' ) '  (Unused entries are 0)'
  write ( *, '(a)' ) ' '
  do i = 1, maxsize
    write ( *, '(i5,g14.6)' ) i, a(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Original unpacked array, as a 2D array:'
  write ( *, '(a)' ) ' '
  do i = 1, maxdim(1)
    ihi = i + ( maxdim(2) - 1 ) * maxdim(1)
    write ( *, '(5f8.4)' ) ( a(k), k = i, ihi, maxdim(1) )
  end do

  call array_size ( rank, dim, size )

  call array_size ( rank, maxdim, size2 )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Number of array elements:'
  write ( *, '(a)' ) ' '
  write ( *, '(a,i6)' ) '    Used:      ', size
  write ( *, '(a,i6)' ) '    Allowed:   ', size2
  write ( *, '(a,i6)' ) '    Allocated: ', maxsize

  call unpack_to_pack ( rank, maxsize, a, maxdim, dim )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Packed array, as a 1D array:'
  write ( *, '(a)' ) ' '
  do i = 1, size
    write ( *, '(i5,g14.6)' ) i, a(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Packed array, as a 2D array:'
  write ( *, '(a)' ) ' '
  do i = 1, dim(1)
    ihi = i + ( dim(2) - 1 ) * dim(1)
    write ( *, '(5f8.4)' ) ( a(k), k = i, ihi, dim(1) )
  end do

  return
end
subroutine test02
!
!*******************************************************************************
!
!! TEST02 tests PACK_SELECT.
!
  implicit none
!
  integer, parameter :: maxsizea = 40
  integer, parameter :: maxsizeb = 12
  integer, parameter :: ranka = 2
!
  real a(maxsizea)
  real b(maxsizeb)
  integer dima(ranka)
  integer dimb(ranka)
  integer dimhi(ranka)
  integer dimlo(ranka)
  integer i
  integer j
  integer k
  integer rankb
  integer sizea
  integer sizeb
!
  do i = 1, maxsizea
    a(i) = - i
  end do

  dima(1:2) =    (/ 5, 6 /)
  dimlo(1:2) =   (/ 3, 3 /)
  dimhi(1:2) =   (/ 4, 5 /)

  k = 0
  do j = 1, dima(2)
    do i = 1, dima(1)
      k = k + 1
      a(k) = real ( 10 * i + j )
    end do
  end do

  call array_size ( ranka, dima, sizea )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST02'
  write ( *, '(a)' ) '  PACK_SELECT selects a subarray from a packed'
  write ( *, '(a)' ) '  array.'
  write ( *, '(a)' ) ' '
  write ( *, '(a,i6)' ) '  Packed array has rank = ', ranka
  write ( *, '(a,i6)' ) '  Packed array has size = ', sizea
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Packed array dimensions:'
  write ( *, '(a)' ) ' '

  do i = 1, ranka
    write ( *, '(2i6)' ) i, dima(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Original packed array, as a 1D array:'
  write ( *, '(a)' ) '  (Unused entries are negative)'
  write ( *, '(a)' ) ' '
  do i = 1, maxsizea
    write ( *, '(i6,g14.6)' ) i, a(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Selection ranges are:'
  write ( *, '(a)' ) ' '
  do i = 1, ranka
    write ( *, '(3i6)' ) i, dimlo(i), dimhi(i)
  end do
 
  call pack_select ( ranka, maxsizea, a, dima, dimlo, dimhi, rankb, &
    maxsizeb, b, dimb )

  call array_size ( rankb, dimb, sizeb )

  write ( *, '(a)' ) ' '
  write ( *, '(a,i6)' ) '  Selected array has rank = ', rankb
  write ( *, '(a,i6)' ) '  Selected array has size = ', sizeb
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Selected array dimensions:'
  write ( *, '(a)' ) ' '

  do i = 1, rankb
    write ( *, '(2i6)' ) i, dimb(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Selected array as a 1 dimensional array:'
  write ( *, '(a)' ) ' '

  do i = 1, sizeb
    write ( *, '(i6,g14.6)' ) i, b(i)
  end do

  return
end
subroutine test03
!
!*******************************************************************************
!
!! TEST03 tests PACK_SELECT.
!
!  In this test, the rank of A is 3, but the rank of B will be 2.
!
  implicit none
!
  integer, parameter :: maxsizea = 40
  integer, parameter :: maxsizeb = 12
  integer, parameter :: ranka = 3
!
  real a(maxsizea)
  real b(maxsizeb)
  integer dima(ranka)
  integer dimb(ranka)
  integer dimhi(ranka)
  integer dimlo(ranka)
  integer i
  integer j
  integer k
  integer l
  integer rankb
  integer sizea
  integer sizeb
!
  do i = 1, maxsizea
    a(i) = - i
  end do

  dima(1:3) =    (/ 3, 3, 3 /)
  dimlo(1:3) =   (/ 1, 2, 1 /)
  dimhi(1:3) =   (/ 3, 2, 3 /)

  l = 0
  do k = 1, dima(3)
    do j = 1, dima(2)
      do i = 1, dima(1)
        l = l + 1
        a(l) = real ( 100 * i + 10 * j + k )
      end do
    end do
  end do

  call array_size ( ranka, dima, sizea )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST03'
  write ( *, '(a)' ) '  PACK_SELECT selects a subarray from a packed'
  write ( *, '(a)' ) '  array.'
  write ( *, '(a)' ) ' '
  write ( *, '(a,i6)' ) '  Packed array has rank = ', ranka
  write ( *, '(a,i6)' ) '  Packed array has size = ', sizea
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Packed array dimensions:'
  write ( *, '(a)' ) ' '

  do i = 1, ranka
    write ( *, '(2i6)' ) i, dima(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Original packed array, as a 1D array:'
  write ( *, '(a)' ) '  (Unused entries are negative)'
  write ( *, '(a)' ) ' '
  do i = 1, maxsizea
    write ( *, '(i6,g14.6)' ) i, a(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Selection ranges are:'
  write ( *, '(a)') ' '
  do i = 1, ranka
    write ( *, '(3i6)' ) i, dimlo(i), dimhi(i)
  end do
 
  call pack_select ( ranka, maxsizea, a, dima, dimlo, dimhi, rankb, &
    maxsizeb, b, dimb )

  call array_size ( rankb, dimb, sizeb )

  write ( *, '(a)' ) ' '
  write ( *, '(a,i6)' ) '  Selected array has rank = ', rankb
  write ( *, '(a,i6)' ) '  Selected array has size = ', sizeb
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Selected array dimensions:'
  write ( *, '(a)' ) ' '

  do i = 1, rankb
    write ( *, '(2i6)' ) i, dimb(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Selected array as a 1 dimensional array:'
  write ( *, '(a)' ) ' '

  do i = 1, sizeb
    write ( *, '(i6,g14.6)' ) i, b(i)
  end do

  return
end
subroutine test04
!
!*******************************************************************************
!
!! TEST04 tests UNPACK_SELECT.
!
  implicit none
!
  integer, parameter :: maxsizea = 50
  integer, parameter :: maxsizeb = 12
  integer, parameter :: ranka = 2
!
  real a(maxsizea)
  real b(maxsizeb)
  integer dima(ranka)
  integer dimb(ranka)
  integer dimhi(ranka)
  integer dimlo(ranka)
  integer i
  integer j
  integer k
  integer maxdima(ranka)
  integer maxsizea2
  integer rankb
  integer sizea
  integer sizeb
!
  do i = 1, maxsizea
    a(i) = - i
  end do

  dima(1:2) =    (/ 5, 6 /)
  maxdima(1:2) = (/ 6, 8 /)
  dimlo(1:2) =   (/ 3, 3 /)
  dimhi(1:2) =   (/ 4, 5 /)

  k = 0
  do j = 1, dima(2)
    do i = 1, dima(1)
      k = k + 1
      a(k) = real ( 10 * i + j )
    end do
  end do

  call array_size ( ranka, dima, sizea )

  call array_size ( ranka, maxdima, maxsizea2 )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST04'
  write ( *, '(a)' ) '  UNPACK_SELECT selects a subarray from an'
  write ( *, '(a)' ) '  unpacked array.'
  write ( *, '(a)' ) ' '
  write ( *, '(a,i6)' ) '  Unpacked array has rank =         ', ranka
  write ( *, '(a,i6)' ) '  Unpacked array has used size =    ', sizea
  write ( *, '(a,i6)' ) '  Unpacked array has maximum size = ', maxsizea2
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Unpacked array used, maximum dimensions:'
  write ( *, '(a)' ) ' '

  do i = 1, ranka
    write ( *, '(3i6)' ) i, dima(i), maxdima(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Original unpacked array, as a 1D array:'
  write ( *, '(a)' ) '  (Unused entries are negative)'
  write ( *, '(a)' ) ' '
  do i = 1, maxsizea
    write ( *, '(i6,g14.6)' ) i, a(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Selection ranges are:'
  write ( *, '(a)' ) ' '
  do i = 1, ranka
    write ( *, '(3i6)' ) i, dimlo(i), dimhi(i)
  end do
 
  call unpack_select ( ranka, maxsizea, a, maxdima, dima, dimlo, dimhi, &
    rankb, maxsizeb, b, dimb )

  call array_size ( rankb, dimb, sizeb )

  write ( *, '(a)' ) ' '
  write ( *, '(a,i6)' ) '  Selected array has rank = ', rankb
  write ( *, '(a,i6)' ) '  Selected array has size = ', sizeb
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Selected array dimensions:'
  write ( *, '(a)' ) ' '

  do i = 1, rankb
    write ( *, '(2i6)' ) i, dimb(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Selected array as a 1 dimensional array:'
  write ( *, '(a)') ' '

  do i = 1, sizeb
    write ( *, '(i6,g14.6)' ) i, b(i)
  end do

  return
end
subroutine test05
!
!*******************************************************************************
!
!! TEST05 tests PACK_GET;
!! TEST05 tests PACK_INC;
!! TEST05 tests PACK_SET.
!
  implicit none
!
  integer, parameter :: maxsize = 15
  integer, parameter :: rank = 2
!
  real a(maxsize)
  integer dim(rank)
  integer i
  integer indx(rank)
  integer j
  integer k
  integer size
  real value
!
  do i = 1, maxsize
    a(i) = - i
  end do

  dim(1) = 3
  dim(2) = 4

  k = 0
  do j = 1, dim(2)
    do i = 1, dim(1)
      k = k + 1
      a(k) = real ( 10 * i + j )
    end do
  end do

  call array_size ( rank, dim, size )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST05'
  write ( *, '(a)' ) '  PACK_SET sets an entry;'
  write ( *, '(a)' ) '  PACK_INC increments it;'
  write ( *, '(a)' ) '  PACK_GET gets it.'
  write ( *, '(a)' ) ' '
  write ( *, '(a,i6)' ) '  Packed array has rank = ', rank
  write ( *, '(a,i6)' ) '  Packed array has size = ', size
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Packed array dimensions:'
  write ( *, '(a)' ) ' '

  do i = 1, rank
    write ( *, '(2i6)' ) i, dim(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Original packed array, as a 1D array:'
  write ( *, '(a)' ) '  (Unused entries are negative)'
  write ( *, '(a)' ) ' '
  do i = 1, maxsize
    write ( *, '(i6,g14.6)' ) i, a(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Use PACK_SET to set entry (2,3) to 5:'

  indx(1) = 2
  indx(2) = 3
  value = 5.0E+00

  call pack_set ( rank, maxsize, a, dim, indx, value )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Current packed array'
  write ( *, '(a)' ) ' '
  do i = 1, maxsize
    write ( *, '(i6,g14.6)' ) i, a(i)
  end do
 
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Use PACK_INC to add 2 to entry (2,3):'

  indx(1) = 2
  indx(2) = 3
  value = 2.0E+00

  call pack_inc ( rank, maxsize, a, dim, indx, value )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Current packed array'
  write ( *, '(a)' ) ' '
  do i = 1, maxsize
    write ( *, '(i6,g14.6)' ) i, a(i)
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Use PACK_GET to get entry (2,3):'

  indx(1) = 2
  indx(2) = 3

  call pack_get ( rank, maxsize, a, dim, indx, value )

  write ( *, '(a)' ) ' '
  write ( *, '(a,g14.6)' ) '  A(2,3) = ', value

  return
end