[Fortran] syntaxhighlighter_viewsource syntaxhighlighter_copycode
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