142 lines
4.1 KiB
Fortran
142 lines
4.1 KiB
Fortran
program stable_marriage
|
|
implicit none
|
|
integer, parameter :: n = 10
|
|
integer :: mens_pref(n, n), womens_pref(n, n)
|
|
integer :: mens_rank(n, n), womens_rank(n, n)
|
|
integer :: wife(n), husband(n), next_prop(n)
|
|
logical :: free_men(n)
|
|
character(len=4) :: men_names(n), women_names(n)
|
|
integer :: m, w, p, h, i, curr_w, w1, w2
|
|
logical :: is_stable
|
|
|
|
! Names
|
|
men_names = ['abe ', 'bob ', 'col ', 'dan ', 'ed ', 'fred', 'gav ', 'hal ', 'ian ', 'jon ']
|
|
women_names = ['abi ', 'bea ', 'cath', 'dee ', 'eve ', 'fay ', 'gay ', 'hope', 'ivy ', 'jan ']
|
|
|
|
! Men's preferences
|
|
mens_pref(1, :) = [1, 5, 3, 9, 10, 4, 6, 2, 8, 7]
|
|
mens_pref(2, :) = [3, 8, 1, 4, 5, 6, 2, 10, 9, 7]
|
|
mens_pref(3, :) = [8, 5, 1, 4, 2, 6, 9, 7, 3, 10]
|
|
mens_pref(4, :) = [9, 6, 4, 7, 8, 5, 10, 2, 3, 1]
|
|
mens_pref(5, :) = [10, 4, 2, 3, 6, 5, 1, 9, 8, 7]
|
|
mens_pref(6, :) = [2, 1, 4, 7, 5, 9, 3, 10, 8, 6]
|
|
mens_pref(7, :) = [7, 5, 9, 2, 3, 1, 4, 8, 10, 6]
|
|
mens_pref(8, :) = [1, 5, 8, 6, 9, 3, 10, 2, 7, 4]
|
|
mens_pref(9, :) = [8, 3, 4, 7, 2, 1, 6, 9, 10, 5]
|
|
mens_pref(10, :) = [1, 6, 10, 7, 5, 2, 4, 3, 9, 8]
|
|
|
|
! Women's preferences
|
|
womens_pref(1, :) = [2, 6, 10, 7, 9, 1, 4, 5, 3, 8]
|
|
womens_pref(2, :) = [2, 1, 3, 6, 7, 4, 9, 5, 10, 8]
|
|
womens_pref(3, :) = [6, 2, 5, 7, 8, 3, 9, 1, 4, 10]
|
|
womens_pref(4, :) = [6, 10, 3, 1, 9, 8, 7, 4, 2, 5]
|
|
womens_pref(5, :) = [10, 8, 6, 4, 1, 7, 3, 5, 9, 2]
|
|
womens_pref(6, :) = [2, 1, 5, 9, 10, 4, 6, 7, 3, 8]
|
|
womens_pref(7, :) = [10, 7, 8, 6, 2, 1, 3, 5, 4, 9]
|
|
womens_pref(8, :) = [7, 10, 2, 1, 9, 4, 8, 5, 3, 6]
|
|
womens_pref(9, :) = [9, 3, 8, 7, 6, 2, 1, 5, 10, 4]
|
|
womens_pref(10, :) = [5, 8, 7, 1, 2, 10, 3, 9, 6, 4]
|
|
|
|
! Build rank matrices
|
|
mens_rank = 0
|
|
do m = 1, n
|
|
do p = 1, n
|
|
w = mens_pref(m, p)
|
|
mens_rank(m, w) = p
|
|
end do
|
|
end do
|
|
womens_rank = 0
|
|
do w = 1, n
|
|
do p = 1, n
|
|
m = womens_pref(w, p)
|
|
womens_rank(w, m) = p
|
|
end do
|
|
end do
|
|
|
|
! Gale-Shapley algorithm
|
|
wife = 0
|
|
husband = 0
|
|
next_prop = 1
|
|
free_men = .true.
|
|
do while (any(free_men))
|
|
do m = 1, n
|
|
if (.not. free_men(m)) cycle
|
|
if (next_prop(m) > n) cycle
|
|
w = mens_pref(m, next_prop(m))
|
|
next_prop(m) = next_prop(m) + 1
|
|
if (husband(w) == 0) then
|
|
husband(w) = m
|
|
wife(m) = w
|
|
free_men(m) = .false.
|
|
else
|
|
h = husband(w)
|
|
if (womens_rank(w, m) < womens_rank(w, h)) then
|
|
husband(w) = m
|
|
wife(m) = w
|
|
free_men(m) = .false.
|
|
wife(h) = 0
|
|
free_men(h) = .true.
|
|
end if
|
|
end if
|
|
end do
|
|
end do
|
|
|
|
! Print stable matching
|
|
print *, 'Stable matching:'
|
|
do m = 1, n
|
|
print *, trim(men_names(m)), ' - ', trim(women_names(wife(m)))
|
|
end do
|
|
|
|
! Check stability of stable matching
|
|
is_stable = .true.
|
|
do m = 1, n
|
|
curr_w = wife(m)
|
|
do i = 1, mens_rank(m, curr_w) - 1
|
|
w = mens_pref(m, i)
|
|
h = husband(w)
|
|
if (womens_rank(w, m) < womens_rank(w, h)) then
|
|
is_stable = .false.
|
|
end if
|
|
end do
|
|
end do
|
|
if (is_stable) then
|
|
print *, 'The matching is stable.'
|
|
else
|
|
print *, 'The matching is not stable.'
|
|
end if
|
|
|
|
! Perturb the matching (swap abe and bob's partners)
|
|
w1 = wife(1)
|
|
w2 = wife(2)
|
|
wife(1) = w2
|
|
wife(2) = w1
|
|
husband(w1) = 2
|
|
husband(w2) = 1
|
|
|
|
! Print perturbed matching
|
|
print *, ''
|
|
print *, 'Perturbed matching: (swap abe and bob''s partners)'
|
|
do m = 1, n
|
|
print *, trim(men_names(m)), ' - ', trim(women_names(wife(m)))
|
|
end do
|
|
|
|
! Check stability of perturbed matching
|
|
is_stable = .true.
|
|
check_loop: do m = 1, n
|
|
curr_w = wife(m)
|
|
do i = 1, mens_rank(m, curr_w) - 1
|
|
w = mens_pref(m, i)
|
|
h = husband(w)
|
|
if (womens_rank(w, m) < womens_rank(w, h)) then
|
|
is_stable = .false.
|
|
print *, 'Unstable because ', trim(men_names(m)), ' and ', trim(women_names(w)), &
|
|
' prefer each other while ', trim(men_names(h)), ' and ', trim(women_names(curr_w)), ' prefer each other'
|
|
exit check_loop ! Show one blocking pair
|
|
end if
|
|
end do
|
|
end do check_loop
|
|
if (is_stable) then
|
|
print *, 'The perturbed matching is stable.'
|
|
end if
|
|
|
|
end program stable_marriage
|