program main use iso_fortran_env, only: int64 implicit none integer :: D, L, k, ant, j, i, cost, mini, cost0, linea, rr, ok, col, okcol integer, dimension(0:5, 0:5) :: map integer, dimension(0:35) :: hj, hi integer, dimension (0:5) :: opt integer(kind=int64) :: kount real :: r D = 6 L = D -1 k = D*D do i = 0, L do j = 0, L k = k - 1 hj ( k ) = j hi ( k ) = i map(i, j) = k end do end do linea = L col = L kount = 0 mini = 999999 CALL init_random_seed() do i=0,L do j=0,L ant = map(i,j) !k = (int) drand48()*(L+1); !ok = (int) drand48()*(L+1); call RANDOM_NUMBER(r) k = floor ( r * D) call RANDOM_NUMBER(r) ok = floor ( r * D) map(i,j) = map(k,ok) map(k,ok) = ant hi(map(k,ok)) = k hj(map(k,ok)) = ok hi(map(i,j)) = i hj(map(i,j)) = j end do end do do k = -1 j = hj(0) i = hi(0) if (j - 1 >= 0) then k = k + 1 opt(k) =0 end if if (i - 1 >= 0) then k = k + 1 opt(k) =1 end if if (j + 1 <= col) then k = k + 1 opt (k) = 2 end if if (i + 1 <= linea) then k = k + 1 opt(k) = 3 end if k = k+1 call random_number(r) rr = opt ( floor ( r * k ) ) select case (rr) case (0) ant = map( i, j-1 ) map( i , j-1 ) = 0 map( i, j ) = ant hj(0) = hj(0)-1 hj(ant) = hj(ant)+1 case (1) ant = map( i - 1 , j ) map( i -1 , j ) = 0 map( i, j ) = ant hi(0)=hi(0)-1 hi(ant)=hi(ant)+1 case (2) ant = map( i , j+1 ) map( i , j+1 ) = 0 map( i, j ) = ant hj(0)=hj(0)+1 hj(ant)=hj(ant)-1 case (3) ant = map( i+1 , j ) map( i+1 , j ) = 0 map( i, j ) = ant hi(0)=hi(0)+1 hi(ant)=hi(ant)-1 case default stop 'great error!' end select cost = 0 k = 0 okcol = 0 do i = 0,L cost0 = 0 do j = 0,L cost0 = cost0 + abs(map(i,j)-k) !*(k+1) if (map(i,j)==k .and. j==col) okcol = okcol +1 k = k + 1 end do cost = cost + cost0 if (cost0 == 0 .AND. i==linea .AND. linea>1) linea = linea -1 end do if (okcol == D .and. col > 1) col = col-1 if (cost <= mini) then ! kount = 0 write (*,*) "COST=", cost do i = 0,L print "(6(i2,' '))", map(i,0), map(i,1), map(i,2), map(i,3), map(i,4), map(i,5) end do write (*,*) mini = cost if (cost == 2) kount = kount + 100000000 ! fan of comp.lang.fortran ! backup(0:L,0:L) = map(0:L,0:L) ! else end if kount = kount + 1 ! if ( mod(kount, 1000) ==0) then ! map(0:L,0:L) = backup(0:L,0:L) ! do i = 0,L ! do j = 0,L ! map(i,j) = backup(i,j) ! hi( map(i,j) ) = i ! hj( map(i,j) ) = j ! end do ! end do ! endif ! endif if (kount > 50000000000_int64) stop "Problem without solution!" if (cost == 0) exit end do end program main subroutine init_random_seed() use iso_fortran_env, only: int64 implicit none integer, allocatable :: seed(:) integer :: i, n, un, istat, dt(8), pid integer(int64) :: t call random_seed(size = n) allocate(seed(n)) ! First try if the OS provides a random number generator open(newunit=un, file="/dev/urandom", access="stream", & form="unformatted", action="read", status="old", iostat=istat) if (istat == 0) then read(un) seed close(un) else ! Fallback to XOR:ing the current time and pid. The PID is ! useful in case one launches multiple instances of the same ! program in parallel. call system_clock(t) if (t == 0) then call date_and_time(values=dt) t = (dt(1) - 1970) * 365_int64 * 24 * 60 * 60 * 1000 & + dt(2) * 31_int64 * 24 * 60 * 60 * 1000 & + dt(3) * 24_int64 * 60 * 60 * 1000 & + dt(5) * 60 * 60 * 1000 & + dt(6) * 60 * 1000 + dt(7) * 1000 & + dt(8) end if pid = getpid() t = ieor(t, int(pid, kind(t))) do i = 1, n seed(i) = lcg(t) end do end if call random_seed(put=seed) contains ! This simple PRNG might not be good enough for real work, but is ! sufficient for seeding a better PRNG. function lcg(s) integer :: lcg integer(int64) :: s if (s == 0) then s = 104729 else s = mod(s, 4294967296_int64) end if s = mod(s * 279470273_int64, 4294967291_int64) lcg = int(mod(s, int(huge(0), int64)), kind(0)) end function lcg end subroutine init_random_seed