program topo2rdirc

  implicit none
  include 'netcdf.inc'

! Notes
! -------------------------------------------------------------------
! This program is a check to make sure all inifinte loops have
! been corrected in fort.10 (generated by topo2rdirc.F90).
! Use this programs as many times as necessary on fort.10 to
! verify that all infinite loops are removed.
!
! The output one ascii files: fort.11.
!
! fort.10 :
! is the river directions map in the format required by CLM.
! fort.11 :
! lists all grid cells involved in infinite river loops.
!
! The user must redirect rivers in the vicinity of infinite loops.
! Alternatively, the user may start with topography which always slopes to
! the ocean, doesn't have internal basins, and doesn't contain completely
! flat plateaus.
!
! slevis, feb 2003, cshields, may2003
! -------------------------------------------------------------------
! Variable declarations
! -------------------------------------------------------------------

  integer, parameter :: r8 = selected_real_kind(12)

! IF YOU CHOOSE A DIFFERENT RESOLUTION (nlon, nlat),
! YOU MUST ALSO READ A DIFFERENT INPUT FILE (filei).
! 2x2 degree
  integer, parameter :: nlon = 180        !input grid : longitude points
  integer, parameter :: nlat =  90        !input grid : latitude  points

! 05x05 degree
! integer, parameter :: nlon = 720        !input grid : longitude points
! integer, parameter :: nlat = 360        !input grid : latitude  points

! 1x1 degree
! integer, parameter :: nlon = 360        !input grid : longitude points
! integer, parameter :: nlat = 180        !input grid : latitude  points
  integer, parameter :: maxsecpass = 1000 !max # of infinite loops

! input file
  character(len=80) :: filei              !input filename
  integer :: ncid                         !netCDF file id for filei
  integer :: lat_id                       !netCDF latitude id
  integer :: lon_id                       !netCDF longitude id
  integer :: topo_id                      !netCDF topography id

! input variables from filei
  real(r8) :: lon(nlon)                   !longitude dimension array
  real(r8) :: lat(nlat)                   !latitude dimension array
  real(r8) :: topo(nlon,nlat)             !topography array

! output related variables
  integer  :: nowat(maxsecpass,2)         !'now at' index
  integer  :: rdirc(nlon,nlat)            !river directions
  integer  :: intbasin(nlon,nlat)         !internal basins
  integer  :: source(nlon,nlat)           !river sources
  real(r8) :: temp(nlon*nlat,3)           !temporary
  real(r8) :: tempo(maxsecpass,4)         !temporary
  real(r8) :: tmpo(4)                     !temporary
  real(r8) :: tmp(nlon*nlat,5)            !temporary

  logical :: dontcount                    !index related to next variable
  integer :: csecpass                     !count 2nd passes => inf. loops
  integer :: secondpass, ocean, ret       !indices
  integer :: ii, jj, i, j, count, line    !indices
  integer :: sort                         !index and
  integer :: locsmallest                  !variables
  integer, dimension(1) :: minlocarray    !used in the
  real(r8) :: smallest                    !sorting loops
  real(r8) :: topomin(8)     !surrounding topography in ascending order

! -------------------------------------------------------------------
! Read in ascii rdirc file
! -------------------------------------------------------------------

  filei = 'fort.10' 
  open (unit = 10, file = filei, status = "old", form='formatted' )

  line = 0
  do j = 1,nlat
  do i = nlon/2+1,nlon      ! ie, 361 to 720 at half degree
    line = line + 1
    read(10,*) temp(line,:)
    lat(j) = temp(line,1) 
    lon(i) = temp(line,2) 
    rdirc(i,j) = temp(line,3)
  end do
  do i = 1,nlon/2           ! ie, 1 to 360 at half degree
   line = line + 1
   read(10,*) temp(line,:)
   lat(j) =   temp(line,1) 
   lon(i) =   temp(line,2)
   rdirc(i,j) = temp(line,3) 
  end do
  end do
	print *, 'lat = ',lat
	print *,' lon = ',lon
!	print *,' rdirc = ',rdirc


write(*,*) 'begin error checks'

! Error checks
! Look for arrows pointing at each other.
! Don't worry about the first and last rows (j=1 and j=360 at half degree),
! because they have been hardwired to point north and south respectively.

do i = 2,nlon-1
  do j = 2,nlat-1
    if     (rdirc(i,j) == 1 .and. rdirc(i,j+1) == 5) then
      pause 'error1'
    elseif (rdirc(i,j) == 2 .and. rdirc(i+1,j+1) == 6) then
      pause 'error2'
    elseif (rdirc(i,j) == 3 .and. rdirc(i+1,j) == 7) then
      pause 'error3'
    elseif (rdirc(i,j) == 4 .and. rdirc(i+1,j-1) == 8) then
      pause 'error4'
    elseif (rdirc(i,j) == 5 .and. rdirc(i,j-1) == 1) then
      pause 'error5'
    elseif (rdirc(i,j) == 6 .and. rdirc(i-1,j-1) == 2) then
      pause 'error6'
    elseif (rdirc(i,j) == 7 .and. rdirc(i-1,j) == 3) then
      pause 'error7'
    elseif (rdirc(i,j) == 8 .and. rdirc(i-1,j+1) == 4) then
      pause 'error8'
    end if
  end do
end do

do j = 2,nlat-1
  if    (rdirc(1,j) == 1 .and. rdirc(1,j+1) == 5) then
      pause 'error9'
  elseif (rdirc(1,j) == 2 .and. rdirc(2,j+1) == 6) then
      pause 'error10'
  elseif (rdirc(1,j) == 3 .and. rdirc(2,j) == 7) then
      pause 'error11'
  elseif (rdirc(1,j) == 4 .and. rdirc(2,j-1) == 8) then
      pause 'error12'
  elseif (rdirc(1,j) == 5 .and. rdirc(1,j-1) == 1) then
      pause 'error13'
  elseif (rdirc(1,j) == 6 .and. rdirc(nlon,j-1) == 2) then
      pause 'error14'
  elseif (rdirc(1,j) == 7 .and. rdirc(nlon,j  ) == 3) then
      pause 'error15'
  elseif (rdirc(1,j) == 8 .and. rdirc(nlon,j+1) == 4) then
      pause 'error16'
  end if
  if     (rdirc(nlon,j) == 1 .and. rdirc(nlon,j+1) == 5) then
      pause 'error17'
  elseif (rdirc(nlon,j) == 2 .and. rdirc(1,j+1) == 6) then
      pause 'error18'
  elseif (rdirc(nlon,j) == 3 .and. rdirc(1,j  ) == 7) then
      pause 'error19'
  elseif (rdirc(nlon,j) == 4 .and. rdirc(1,j-1) == 8) then
      pause 'error20'
  elseif (rdirc(nlon,j) == 5 .and. rdirc(nlon,j-1) == 1) then
      pause 'error21'
  elseif (rdirc(nlon,j) == 6 .and. rdirc(nlon-1,j-1) == 2) then
      pause 'error22'
  elseif (rdirc(nlon,j) == 7 .and. rdirc(nlon-1,j  ) == 3) then
      pause 'error23'
  elseif (rdirc(nlon,j) == 8 .and. rdirc(nlon-1,j+1) == 4) then
      pause 'error24'
  end if
end do

write(*,*) 'end error checks'



source = 0              ! initialize
csecpass = 0            ! variables
                        ! ***           TO ALL USERS                ***
do i = 2,nlon-1         ! *** Pls check manually for infinite loops ***
  do j = 2,nlat-1       ! ***      at the edges of the domain       ***
    if (rdirc(i,j) > 0) then
      if (rdirc(i,j+1) /= 5 .and. rdirc(i+1,j+1) /= 6 .and. &
          rdirc(i+1,j) /= 7 .and. rdirc(i+1,j-1) /= 8 .and. &
          rdirc(i,j-1) /= 1 .and. rdirc(i-1,j-1) /= 2 .and. &
          rdirc(i-1,j) /= 3 .and. rdirc(i-1,j+1) /= 4) then
        source(i,j) = 1 ! river source
      end if
    end if
  end do
end do

write(*,*) 'Found river sources. Now follow rivers to the ocean.'

do i = 2,nlon-1
  do j = 2,nlat-1
    if (source(i,j) == 1) then
      nowat = 0; jj = j; ii = i; secondpass = 0; ocean = 0; count = 1
      do while (secondpass == 0 .and. ocean == 0)
        if (ii < 1) then
          ii = nlon
        elseif (ii > nlon) then
          ii = 1
        end if
        count = count + 1
        nowat(count,1) = jj
        nowat(count,2) = ii
        if     (rdirc(ii,jj) == 1) then
          jj = jj + 1;
        elseif (rdirc(ii,jj) == 2) then
          jj = jj + 1;
          ii = ii + 1;
        elseif (rdirc(ii,jj) == 3) then
          ii = ii + 1;
        elseif (rdirc(ii,jj) == 4) then
          ii = ii + 1;
          jj = jj - 1;
        elseif (rdirc(ii,jj) == 5) then
          jj = jj - 1;
        elseif (rdirc(ii,jj) == 6) then
          jj = jj - 1;
          ii = ii - 1;
        elseif (rdirc(ii,jj) == 7) then
          ii = ii - 1;
        elseif (rdirc(ii,jj) == 8) then
          jj = jj + 1;
          ii = ii - 1;
        elseif (rdirc(ii,jj) == 0) then
          ocean = 1                       ! reached the ocean
        end if
        do sort = 1,count-1
          if (nowat(sort,1) == nowat(count,1) .and. &
              nowat(sort,2) == nowat(count,2)) then
            secondpass = 1;               ! found an infinite loop
            tmpo(1) = jj
            tmpo(2) = ii
            tmpo(3) = lat(jj)
            tmpo(4) = lon(ii)
            if (csecpass == 0) then       ! first infinite loop to be counted
              tempo(1,1) = 0
              tempo(1,2) = 0
              tempo(1,3) = 0
              tempo(1,4) = 0
            end if
            dontcount = .false.
            do line = 1,maxsecpass
              if (tempo(line,1)==tmpo(1) .and. tempo(line,2)==tmpo(2) .and. &
                  tempo(line,3)==tmpo(3) .and. tempo(line,4)==tmpo(4)) then
                dontcount = .true.        ! avoid double counting
              end if
            end do
            if (.not. dontcount) then
              csecpass = csecpass + 1;    !count infinite loops
              tempo(csecpass,1) = jj      !NB: I have shifted ii & lon(ii)
              tempo(csecpass,2) = ii      !in fort.10 (not fort.11) to go from
              tempo(csecpass,3) = lat(jj) !-180 to 180 degrees (see comment
              tempo(csecpass,4) = lon(ii) !after 'end error checks')
              write(11,*) tempo(csecpass,:)
            end if
          end if
        end do
      end do                              ! while secondpass = 0 AND ocean = 0
    end if                                ! source
  end do                                  ! j loop
end do                                    ! i loop


end program topo2rdirc

!===============================================================================

subroutine handle_error(ret)
  implicit none
  include 'netcdf.inc'
  integer :: ret
  if (ret .ne. nf_noerr) then
     write(6,*) 'NCDERR: ERROR: ',nf_strerror(ret)
     call abort
  endif
end subroutine handle_error

!==============================================================================

subroutine wrap_inq_varid (nfid, varname, varid)
  implicit none
  include 'netcdf.inc'

  integer nfid, varid
  character*(*) varname

  integer ret

  ret = nf_inq_varid (nfid, varname, varid)
  if (ret.ne.NF_NOERR) call handle_error (ret)
end subroutine wrap_inq_varid

!=============================================================================

subroutine wrap_get_var8 (nfid, varid, arr)
  implicit none
  include 'netcdf.inc'

  integer nfid, varid
  real*8 arr(*)

  integer ret

  ret = nf_get_var_double (nfid, varid, arr)
  if (ret.ne.NF_NOERR) call handle_error (ret)
end subroutine wrap_get_var8

!==============================================================================

subroutine endrun
  implicit none
  include 'netcdf.inc'

  call abort
  stop 999
end subroutine endrun


!===============================================================================
