aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Sync

Browse source
This commit is contained in:
Ingy döt Net 2013-10-27 22:24:23 +00:00
parent 6f050a029e
commit 776bba907c
3887 changed files with 59894 additions and 7280 deletions
Download patch file Download diff file Expand all files Collapse all files

228
Task/N-queens-problem/Fortran/n-queens-problem-3.f
View file

@ -1,106 +1,122 @@
MODULE QUEENS_MOD
IMPLICIT NONE
INTEGER, PARAMETER :: LONG=SELECTED_INT_KIND(17)
CONTAINS
FUNCTION PQUEENS(N,K1,K2) RESULT(M)
IMPLICIT NONE
INTEGER(KIND=LONG) :: M
INTEGER, INTENT(IN) :: N,K1,K2
INTEGER, PARAMETER :: L=20
INTEGER :: A(L),S(L),U(4*L-2)
INTEGER :: I,J,Y,Z,P,Q,R
DO 10 I=1,N
10 A(I)=I
DO 20 I=1,4*N-2
20 U(I)=0
M=0
R=2*N-1
IF(K1.EQ.K2) RETURN
P=1-K1+N
Q=1+K1-1
IF((U(P).NE.0).OR.(U(Q+R).NE.0)) RETURN
U(P)=1
U(Q+R)=1
Z=A(1)
A(1)=A(K1)
A(K1)=Z
P=2-K2+N
Q=2+K2-1
IF((U(P).NE.0).OR.(U(Q+R).NE.0)) RETURN
U(P)=1
U(Q+R)=1
IF(K2.NE.1) THEN
Z=A(2)
A(2)=A(K2)
A(K2)=Z
ELSE
Z=A(2)
A(2)=A(K1)
A(K1)=Z
END IF
I=3
GO TO 40
30 S(I)=J
U(P)=1
U(Q+R)=1
I=I+1
40 IF(I.GT.N) GO TO 80
J=I
50 Z=A(I)
Y=A(J)
P=I-Y+N
Q=I+Y-1
A(I)=Y
A(J)=Z
IF((U(P).EQ.0).AND.(U(Q+R).EQ.0)) GO TO 30
60 J=J+1
IF(J.LE.N) GO TO 50
70 J=J-1
IF(J.EQ.I) GO TO 90
Z=A(I)
A(I)=A(J)
A(J)=Z
GO TO 70
80 M=M+1
90 I=I-1
IF(I.EQ.2) RETURN
P=I-A(I)+N
Q=I+A(I)-1
J=S(I)
U(P)=0
U(Q+R)=0
GO TO 60
END FUNCTION
END MODULE
PROGRAM QUEENS
USE OMP_LIB
USE QUEENS_MOD
IMPLICIT NONE
INTEGER, PARAMETER :: L=20
INTEGER :: N,I,J,A(L*L,2),K,P,Q
INTEGER(KIND=LONG) :: S,B(L*L)
DOUBLE PRECISION :: T1,T2
DO N=6,18
K=0
P=N/2
Q=MOD(N,2)*(P+1)
DO I=1,N
DO J=1,N
IF((ABS(I-J).GT.1).AND.((I.LE.P).OR.((I.EQ.Q).AND.(J.LT.I)))) THEN
K=K+1
A(K,1)=I
A(K,2)=J
END IF
END DO
END DO
S=0
T1=OMP_GET_WTIME()
C$OMP PARALLEL DO SCHEDULE(DYNAMIC)
DO I=1,K
B(I)=PQUEENS(N,A(I,1),A(I,2))
END DO
C$OMP END PARALLEL DO
T2=OMP_GET_WTIME()
PRINT '(I4,I12,F12.3)',N,2*SUM(B(1:K)),T2-T1
END DO
END PROGRAM
program queens
use omp_lib
implicit none
integer, parameter :: long = selected_int_kind(17)
integer, parameter :: l = 18
integer :: n, i, j, a(l*l, 2), k, p, q
integer(long) :: s, b(l*l)
real(kind(1d0)) :: t1, t2
do n = 6, l
k = 0
p = n/2
q = mod(n, 2)*(p + 1)
do i = 1, n
do j = 1, n
if ((abs(i - j) > 1) .and. ((i <= p) .or. ((i == q) .and. (j < i)))) then
k = k + 1
a(k, 1) = i
a(k, 2) = j
end if
end do
end do
s = 0
t1 = omp_get_wtime()
!$omp parallel do schedule(dynamic)
do i = 1, k
b(i) = pqueens(n, a(i, 1), a(i, 2))
end do
!$omp end parallel do
t2 = omp_get_wtime()
print "(I4, I12, F12.3)", n, 2*sum(b(1:k)), t2 - t1
end do
contains
function pqueens(n, k1, k2) result(m)
implicit none
integer(long) :: m
integer, intent(in) :: n, k1, k2
integer, parameter :: l = 20
integer :: a(l), s(l), u(4*l - 2)
integer :: i, j, y, z, p, q, r
do i = 1, n
a(i) = i
end do
do i = 1, 4*n - 2
u(i) = 0
end do
m = 0
r = 2*n - 1
if (k1 == k2) return
p = 1 - k1 + n
q = 1 + k1 - 1
if ((u(p) /= 0) .or. (u(q + r) /= 0)) return
u(p) = 1
u(q + r) = 1
z = a(1)
a(1) = a(k1)
a(k1) = z
p = 2 - k2 + n
q = 2 + k2 - 1
if ((u(p) /= 0) .or. (u(q + r) /= 0)) return
u(p) = 1
u(q + r) = 1
if (k2 /= 1) then
z = a(2)
a(2) = a(k2)
a(k2) = z
else
z = a(2)
a(2) = a(k1)
a(k1) = z
end if
i = 3
go to 40
30 s(i) = j
u(p) = 1
u(q + r) = 1
i = i + 1
40 if (i > n) go to 80
j = i
50 z = a(i)
y = a(j)
p = i - y + n
q = i + y - 1
a(i) = y
a(j) = z
if ((u(p) == 0) .and. (u(q + r) == 0)) go to 30
60 j = j + 1
if (j <= n) go to 50
70 j = j - 1
if (j == i) go to 90
z = a(i)
a(i) = a(j)
a(j) = z
go to 70
!valid queens position found
80 m = m + 1
90 i = i - 1
if (i == 2) return
p = i - a(i) + n
q = i + a(i) - 1
j = s(i)
u(p) = 0
u(q + r) = 0
go to 60
end function
end program