subroutine swap ( varval, class, clsize, in, ik, iv, critvl, ntrans, ifault )
!*****************************************************************************80
!
!! swap() interchanges objects between different classes to improve a criterion.
!
! Discussion:
!
! This routine is given a classification of objects, including the
! number of objects in each class, and the current value of some criterion
! which is desired to be minimized.
!
! The routine calculates the change in criterion for all possible swaps,
! that is, operations in which two objects in different classes exchange
! places. Each swap that would result in a lowering of the criterion is
! executed, and the related quantities are updated.
!
! When no more advantageous swaps can be found, the routine returns.
!
! The routine relies on a user-supplied routine, CRSWAP, to report the
! expected change in the criterion for a given swap, and to carry
! out that transfer if requested.
!
! The variables CLASS and CRITVL have been added to the argument list
! of CRSWAP.
!
! Also, the order of the two classes "L" and "M" was interchanged in
! the call to CRSWAP. The original order was counterintuitive.
!
! Licensing:
!
! This code is distributed under the MIT license.
!
! Modified:
!
! 28 August 2021
!
! Author:
!
! Original FORTRAN77 version by Banfield, Bassill.
! FORTRAN90 version by John Burkardt.
!
! Reference:
!
! Colin Banfield, LC Bassill,
! Algorithm AS 113:
! A transfer for non-hierarchichal classification,
! Applied Statistics,
! Volume 26, Number 2, 1977, pages 206-210.
!
! Input:
!
! real ( kind = rk ) VARVAL(IN,IV), the data values. There are
! IN objects, each having spatial dimension IV.
!
! integer CLASS(IN), the classification of each object.
!
! integer CLSIZE(IK), the number of objects in each class.
!
! integer IN, the number of objects.
!
! integer IK, the number of classes.
!
! integer IV, the number of spatial dimensions,
! or variates, of the objects.
!
! real ( kind = rk ) CRITVL, the current value of the criterion.
!
! Output:
!
! integer CLASS(IN), the updated classification of each object.
!
! integer CLSIZE(IK), the updated number of objects in each class.
!
! real ( kind = rk ) CRITVL, the current value of the criterion.
!
! integer NTRANS, the number of transfers executed.
!
! integer IFAULT, error indicator.
! 0, no error detected.
! 1, the number of classes was less than 2.
! 2, the number of objects was less than the number of classes.
!
implicit none
integer, parameter :: rk = kind ( 1.0D+00 )
integer ik
integer in
integer iv
integer class(in)
integer clsize(ik)
real ( kind = rk ) critvl
real ( kind = rk ), parameter :: eps = 1.0D-38
integer i
integer icount
integer ifault
real ( kind = rk ) inc
integer iswitch
integer it
integer itop
integer j
integer k
integer l
integer m
integer ntrans
real ( kind = rk ) varval(in,iv)
if ( ik <= 1 ) then
ifault = 1
return
end if
if ( in <= ik ) then
ifault = 2
return
end if
ifault = 0
icount = 0
ntrans = 0
itop = ( in * ( in - 1 ) ) / 2
i = 1
do
i = i + 1
if ( itop <= icount ) then
exit
end if
if ( in < i ) then
i = 1
cycle
end if
l = class(i)
k = l
it = i - 1
!
! Test the swap of object I from class M to L,
! and object J from class L to M.
!
do j = 1, it
icount = icount + 1
m = class(j)
if ( l /= j ) then
if ( clsize(l) /= 1 .or. clsize(m) /= 1 ) then
iswitch = 1
call crswap ( varval, class, clsize, in, ik, iv, critvl, &
i, j, l, m, iswitch, inc )
if ( inc < - eps ) then
critvl = critvl + inc
icount = 0
iswitch = 2
call crswap ( varval, class, clsize, in, ik, iv, critvl, &
i, j, l, m, iswitch, inc )
ntrans = ntrans + 1
class(i) = m
class(j) = l
l = m
end if
end if
end if
end do
end do
return
end
subroutine trnsfr ( varval, class, clsize, in, ik, iv, critvl, ntrans, ifault )
!*****************************************************************************80
!
!! trnsfr() transfers objects between classes to improve a criterion.
!
! Discussion:
!
! This routine is given a classification of objects, including the
! number of objects in each class, and the current value of some criterion
! which is desired to be minimized.
!
! The routine calculates the change in criterion for all possible transfers
! of any object from its current class to a different class. Each transfer
! that would result in a lowering of the criterion is executed, and the
! related quantities are updated.
!
! When no more advantageous transfers can be found, the routine returns.
!
! The routine relies on a user-supplied routine, CRTRAN, to report the
! expected change in the criterion for a given transfer, and to carry
! out that transfer if requested.
!
! The variables CLASS and CRITVL have been added to the argument list
! of CRTRAN.
!
! Also, the order of the two classes "L" and "M" was interchanged in
! the call to CRTRAN. The original order was counterintuitive.
!
! Licensing:
!
! This code is distributed under the MIT license.
!
! Modified:
!
! 28 August 2021
!
! Author:
!
! Original FORTRAN77 version by Banfield, Bassill.
! FORTRAN90 version by John Burkardt.
!
! Reference:
!
! Colin Banfield, LC Bassill,
! Algorithm AS 113:
! A transfer for non-hierarchichal classification,
! Applied Statistics,
! Volume 26, Number 2, 1977, pages 206-210.
!
! Input:
!
! real ( kind = rk ) VARVAL(IN,IV), the data values. There are IN
! objects, each having spatial dimension IV.
!
! integer CLASS(IN), the classification of each object.
!
! integer CLSIZE(IK), the number of objects in each class.
!
! integer IN, the number of objects.
!
! integer IK, the number of classes.
!
! integer IV, the number of spatial dimensions, or
! variates, of the objects.
!
! real ( kind = rk ) CRITVL, the current value of the criterion.
!
! Output:
!
! integer CLASS(IN), the updated classification of each object.
!
! integer CLSIZE(IK), the updated number of objects in each class.
!
! real ( kind = rk ) CRITVL, the current value of the criterion.
!
! integer NTRANS, the number of transfers executed.
!
! integer IFAULT, error indicator.
! 0, no error detected.
! 1, the number of classes was less than 2.
! 2, the number of objects was less than the number of classes.
!
implicit none
integer, parameter :: rk = kind ( 1.0D+00 )
integer ik
integer in
integer iv
integer class(in)
integer clsize(ik)
real ( kind = rk ) critvl
real ( kind = rk ), parameter :: eps = 1.0D-38
integer i
integer icount
integer ifault
real ( kind = rk ) inc
real ( kind = rk ) inco
integer iswitch
integer l
integer lo
integer m
integer ntrans
real ( kind = rk ) varval(in,iv)
if ( ik <= 1 ) then
ifault = 1
return
end if
if ( in <= ik ) then
ifault = 2
return
end if
ifault = 0
ntrans = 0
i = 0
icount = 0
do
i = i + 1
if ( in <= icount ) then
exit
end if
if ( in < i ) then
i = 0
icount = 0
cycle
end if
m = class(i)
if ( clsize(m) <= 1 ) then
icount = icount + 1
cycle
end if
inco = - eps
lo = m
!
! Test the transfer of object I from class M to class L.
!
do l = 1, ik
if ( l /= m ) then
iswitch = 1
call crtran ( varval, class, clsize, in, ik, iv, critvl, &
i, m, l, iswitch, inc )
!
! Remember the values of L and INC.
!
if ( inc < inco ) then
lo = l
inco = inc
end if
end if
end do
icount = icount + 1
!
! Execute the transfer of object I from class M to class LO.
!
if ( lo /= m ) then
l = lo
critvl = critvl + inco
icount = 0
iswitch = 2
call crtran ( varval, class, clsize, in, ik, iv, critvl, &
i, m, l, iswitch, inc )
ntrans = ntrans + 1
class(i) = l
clsize(l) = clsize(l) + 1
clsize(m) = clsize(m) - 1
end if
end do
return
end