[Fortran] 纯文本查看 复制代码
Program www_fcode_cn
Implicit None
Integer , parameter :: N = 4
Integer , parameter :: M = 4
real :: gx , gy
Integer :: a( M , N )
Open( 12 , File = '文件名' )
Read( 12 , * ) a
Close( 12 )
call IslandGravity( a , N , M , gx , gy )
write(*,*) gx , gy
contains
Subroutine IslandGravity( d , n , m , gx , gy )
Integer :: n , m
Integer :: d( m , n ) , a( m , n )
integer :: i , j , c , iShiftX , iShiftY
Real :: gx , gy
Logical :: blink
a = d !// 复制一份 a
iShiftX = 0
iShiftY = 0
Do !// 向上滚动，直到没有上下链接为止
blink = Check_Y_Link( a , n , m )
if ( blink ) then
call RollUp( a , n , m )
iShiftY = iShiftY + 1
else
Exit
end if
End Do
Do !// 向左滚动，直到没有左右链接为止
blink = Check_X_Link( a , n , m )
if ( blink ) then
call RollLeft( a , n , m )
iShiftX = iShiftX + 1
else
Exit
end if
End Do
gx = 0.
gy = 0.
c = 0
Do i = 1 , N
Do j = 1 , M
if ( a(j,i) == 1 ) then
gx = gx + j
gy = gy + i
c = c + 1
end if
End Do
End Do
gx = ( gx / c ) + iShiftX !// 最后再把偏移量加上去
if ( gx > m ) gx = gx - m
gy = ( gy / c ) + iShiftY
if ( gy > n ) gy = gy - n
End Subroutine IslandGravity
Subroutine RollUp( a , n , m ) !// 区域向上滚动
Integer :: n , m
Integer :: a( m , n ) , t( m )
t(:) = a( : , 1 )
a(:,1:n-1) = a(:,2:n)
a(:,n) = t(:)
End Subroutine RollUp
Subroutine RollLeft( a , n , m ) !// 区域向左滚动
Integer :: n , m
Integer :: a( m , n ) , t( n )
t(:) = a( 1 , : )
a(1:m-1,:) = a(2:m,:)
a(m,:) = t(:)
End Subroutine RollLeft
Logical Function Check_Y_Link( a , n , m ) !// 检查是否有上下链接
Integer :: n , m
Integer :: a( m , n )
integer :: i
Check_Y_Link = .false.
Do i = 1 , m
if ( ( a(i,1) == 1 ) .and. ( a(i,n) == 1 ) ) then
Check_Y_Link = .true.
return
end if
End Do
End Function Check_Y_Link
Logical Function Check_X_Link( a , n , m ) !// 检查是否有左右链接
Integer :: n , m
Integer :: a( m , n )
integer :: i
Check_X_Link = .false.
Do i = 1 , n
if ( ( a(1,i) == 1 ) .and. ( a(m,i) == 1 ) ) then
Check_X_Link = .true.
return
end if
End Do
End Function Check_X_Link
End Program www_fcode_cn