module tspparsa ! ! Parallel Simulated Annealing method for solving TSP ! use tspglobals use tsputils implicit none include 'mpif.h' contains subroutine run_parallel_sa real :: distance, new_distance real :: tem ! temperature integer :: tem_change_index, tem_trial_index integer :: tour_changes integer :: i1, i2, i3 integer :: last_sample_trial real :: rand integer :: mpierror, mpisize, mpirank integer, dimension(MPI_STATUS_SIZE) :: mpistatus integer :: to, from real :: impr_distance = 0 integer :: improvements = 0 call MPI_Init(mpierror) if (mpierror /= 0) then stop 'Error initialising MPI' end if call MPI_Comm_size(MPI_COMM_WORLD, mpisize, mpierror) call MPI_Comm_rank(MPI_COMM_WORLD, mpirank, mpierror) if (mpirank == 0) then print *, 'Using Parallel Simulated Annealing method.' end if ! use different initial temperatures tem_init = tem_init * exp(-real(mpirank) / real(mpisize-1) * 10) print *, mpirank, 'using initial tem:', tem_init ! initial tour if (init_type == INIT_NUMERICAL) then call numerical_tour(city_order) else if (init_type == INIT_RANDOM) then call random_tour(city_order) else if (init_type == INIT_GREEDY) then call greedy_tour(city_order) end if ! other initialisation trials = 1 last_sample_trial = 1 distance = tour_len(city_order) city_order_min = city_order distance_min = distance tem = tem_init tour_changes = 0 if (mpirank == 0) then print *, 'trials ', 'distance_min ', 'tem ', 'tour_changes ' print *, trials, distance_min, tem, tour_changes end if loop_schedule: do tem_change_index = 1, sched_changes if (sched_type == SCHED_LINEAR) then tem = tem_init * (1 - real(tem_change_index) / real(sched_changes)) else if (sched_type == SCHED_QUADRATIC) then tem = tem_init - sched_quad_const * tem_change_index**2 else if (sched_type == SCHED_STEP) then !if (tem_change_index == sched_changes/2) then ! tem = 0 !end if if (tem_change_index > sched_changes/2) then tem = 0 else tem = tem_init * (1 - real(tem_change_index * 2) / real(sched_changes)) end if end if loop_at_tem: do tem_trial_index = 1, trials_at_tem ! perturb tour if (perturb_type == PERTURB_SWAP) then call random_number(rand) i1 = rand * n_cities call random_number(rand) i2 = rand * n_cities new_distance = swapped_distance(city_order, distance, i1, i2) ! determine whether to accept perturbation if (metrop_boltz(new_distance - distance, tem)) then call swap_operator(city_order, i1, i2) distance = new_distance tour_changes = tour_changes + 1 end if else if (perturb_type == PERTURB_REVSHIFT) then call random_number(rand) i1 = rand * n_cities call random_number(rand) i2 = rand * n_cities ! reverse or shift? call random_number(rand) if (rand < 0.5) then ! reverse segment new_distance = reversed_distance(city_order, distance, i1, i2) ! determine whether to accept perturbation if (metrop_boltz(new_distance - distance, tem)) then call reverse_operator(city_order, i1, i2) distance = new_distance tour_changes = tour_changes + 1 end if else ! shift segment new_distance = shifted_distance(city_order, distance, i1, i2, i3) ! determine whether to accept perturbation if (metrop_boltz(new_distance - distance, tem)) then call shift_operator(city_order, i1, i2, i3) distance = new_distance tour_changes = tour_changes + 1 end if end if end if trials = trials + 1 ! recalculate true distance occasionally to avoid rounding errors if (mod(trials, recalc_trials) == 0) then distance = tour_len(city_order) end if ! evaluate if (distance < distance_min) then distance_min = distance city_order_min = city_order if (show_chgs) then if (mpirank == 0) then if (trials - last_sample_trial >= sampling_threshold) then print *, trials, distance_min, tem, tour_changes last_sample_trial = trials end if end if end if end if ! print status out_samples times if (mpirank == 0) then if (mod(trials, out_sample_trials) == 0) then print *, trials, distance_min, tem, tour_changes end if end if end do loop_at_tem ! synchronise if (mpirank == 0) then ! select best result from all processes do from = 1, mpisize-1 call MPI_Recv(city_order, n_cities, MPI_INTEGER, from, 0, & & MPI_COMM_WORLD, mpistatus, mpierror) call MPI_Recv(distance, 1, MPI_REAL4, from, 0, & & MPI_COMM_WORLD, mpistatus, mpierror) !distance = tour_len(city_order) !print *, 'from', from, 'length', distance if (distance < distance_min) then city_order_min = city_order impr_distance = impr_distance + distance_min - distance improvements = improvements + 1 distance_min = distance end if end do ! synchronise all processes with best so far do to = 1, mpisize-1 call MPI_Send(city_order_min, n_cities, MPI_INTEGER, to, 0, & & MPI_COMM_WORLD, mpierror) call MPI_Send(distance_min, 1, MPI_REAL4, to, 0, & & MPI_COMM_WORLD, mpierror) end do else ! send my best so far call MPI_Send(city_order_min, n_cities, MPI_INTEGER, 0, 0, & & MPI_COMM_WORLD, mpierror) call MPI_Send(distance_min, 1, MPI_REAL4, 0, 0, & & MPI_COMM_WORLD, mpierror) ! receive new tour call MPI_Recv(city_order_min, n_cities, MPI_INTEGER, 0, 0, & & MPI_COMM_WORLD, mpistatus, mpierror) call MPI_Recv(distance_min, 1, MPI_REAL4, 0, 0, & & MPI_COMM_WORLD, mpistatus, mpierror) end if ! use minimum so far as starting point city_order = city_order_min distance = distance_min end do loop_schedule if (mpirank == 0) then call cpu_time( time_end ) distance_min = tour_len(city_order_min) ! ! output results ! print *, '' print *, 'Number of city orders tried: ', trials print *, 'Trip distance: ', distance_min print *, 'Solution tour: ', city_order_min print *, 'Improvement from others: ', impr_distance, 'from', improvements print *, '' print *, 'Execution time: ', time_end - time_begin, ' seconds' if (validate_tour(city_order_min) == .false.) then print *, '!!! TOUR INVALID !!!' end if end if call MPI_Finalize(mpierror) stop end subroutine run_parallel_sa end module tspparsa