module pop_interface

! !DESCRIPTION:
! This is the interface to the main driver for the Parallel Ocean Program (POP).
!

! !USES:
  use POP_KindsMod
  use POP_ErrorMod
  use POP_FieldMod
  use POP_GridHorzMod
  use POP_CommMod
  use POP_InitMod
  use POP_HaloMod

  use kinds_mod, only: int_kind, r8
  use blocks
  use communicate, only: my_task, master_task, MPI_COMM_OCN
  use gather_scatter
  use grid
  use constants, only: grav
  use domain, only: distrb_clinic, nprocs_clinic, nprocs_tropic, clinic_distribution_type, &
         tropic_distribution_type, ew_boundary_type, ns_boundary_type
  use forcing_fields, only: SMF, SMFT, lsmft_avail, STF
  use forcing_shf, only: set_shf, SHF_QSW, shf_filename, shf_data_type, &
                         shf_formulation, shf_interp_freq, shf_interp_type!, shf_restore_tau
  use forcing_ws, only: set_ws, ws_filename, ws_data_type, ws_data_next, ws_data_update, ws_interp_freq, ws_interp_type, &
      ws_interp_next, ws_interp_last, ws_interp_inc
  use forcing_sfwf, only: sfwf_filename, sfwf_data_type, sfwf_formulation, sfwf_interp_freq, sfwf_interp_type, fwf_imposed
  use forcing_tools, only: never
  use initial, only: init_ts_option, init_ts_file, init_ts_file_fmt
  use io_types, only: nml_filename
  use operators, only: wcalc
  use prognostic, only: TRACER, PSURF, PGUESS, GRADPX, GRADPY, UVEL, VVEL, UBTROP, VBTROP, RHO, curtime, oldtime, newtime
  use restart, only: restart_freq_opt, restart_freq, restart_outfile
  use tavg, only: tavg_freq_opt, tavg_freq, tavg_outfile
  use movie, only: movie_freq_opt, movie_freq, movie_outfile
  use timers, only: timer_print_all, get_timer, timer_start, timer_stop
  use time_management
!   use time_management, only: get_time_flag_id, check_time_flag, &
!       nsteps_run, stdout, exit_pop, override_time_flag
  use step_mod, only: step
  use state_mod, only: state
  use diagnostics, only: check_KE
  use output, only: output_driver
  use exit_mod, only: sigAbort, sigExit
! use io, only:

  implicit none

!interface
!    subroutine start_timer ( ) bind (c)
!      use iso_c_binding
!    end subroutine start_timer
!    subroutine stop_timer ( time ) bind (c)
!      use iso_c_binding
!      real (c_float) :: time
!    end subroutine stop_timer
!end interface

!-----------------------------------------------------------------------
!
! module private variables
!
!-----------------------------------------------------------------------

  integer (POP_i4) :: &
     errorCode ! error flag

  integer (int_kind) :: &
     timer_step,        &! timer number for step
     fstop_now           ! flag id for stop_now flag

  logical :: &
     fupdate_coriolis,  &! flag for update coriolis force
     fupdate_wind_stress ! flag for update wind stress

  logical :: initialized = .false.

  real (r8), dimension (nx_block, ny_block, max_blocks_clinic) :: &
     tau_x, tau_y   ! wind stress on t grid in N/m**2

  real (r8), dimension (nx_block, ny_block, km, max_blocks_clinic) :: &
     WVEL           ! 3D vertical velocity field, derived from UVEL and VVEL using wcalc

  real (r8), dimension (:,:), allocatable :: &
     WORK_G            ! temporary 2D array for gathered data

contains

!-----------------------------------------------------------------------
!
! pre-initialize the model run
!
!-----------------------------------------------------------------------
function initialize_code() result(ret)
  integer :: ret

  errorCode = POP_Success
  nml_filename="amuse.nml"

  call POP_Initialize0(errorCode)

! always allocate
!do same for horizontal grid(allocate first, deallocate if not amuse)
  allocate(KMT_G(nx_global,ny_global))

  if (errorCode /= POP_Success) then
    ret=-2
  else
    ret=0
  endif
end function

!-----------------------------------------------------------------------
!
! fully initialize the model run
!
!-----------------------------------------------------------------------
function commit_parameters() result(ret)
  integer :: ret

  !call POP_CommInitMessageEnvironment

  ret=0
  errorCode = POP_Success

  if(topography_opt.NE.'amuse') then
    deallocate(KMT_G) ! will be reallocated later
  endif
  !if(horiz_grid_opt.EQ.'amuse') then
  !  allocate (ULAT_G(nx_global, ny_global), &
  !            ULON_G(nx_global, ny_global))

  call POP_Initialize(errorCode)

  fstop_now = get_time_flag_id('stop_now')
  fupdate_coriolis = .false.
  fupdate_wind_stress = .false.

  !allocate space for gather of global field
  if (my_task == master_task) then
    allocate(WORK_G(nx_global,ny_global))
  endif

  !-----------------------------------------------------------------------
  !
  ! start up the main timer
  !
  !-----------------------------------------------------------------------

  call get_timer(timer_total,'TOTAL',1,distrb_clinic%nprocs)
  call timer_start(timer_total)

  call get_timer(timer_step,'STEP',1,distrb_clinic%nprocs)

  !-----------------------------------------------------------------------
  !
  ! set windstress to that it can be read before the first step is run
  !
  !-----------------------------------------------------------------------
  if (lsmft_avail) then
    call set_ws(SMF, SMFT=SMFT)
  else
    call set_ws(SMF)
  endif

  !-----------------------------------------------------------------------
  !
  ! set surface heat flux so that it can be read before the first step
  ! this also sets SHF_QSW, although not passed as an argument
  !
  !-----------------------------------------------------------------------
  call set_shf(STF)

  initialized = .true.

  ! ensure the forcings can be read
  ret = prepare_parameters()

  ! ensure full grid info is present on master_task
  call initialize_global_grid

  if (errorCode /= POP_Success) then
    ret=-2
  endif
end function

!-----------------------------------------------------------------------
!
! advance the model in time until the model has run for 'tend' seconds
!
!-----------------------------------------------------------------------
function evolve_model(tend) result(ret)
  integer :: ret
  real(8), intent(in) :: tend

  ! stepsize_next is the time in seconds for next timestep
  ! it is set and updated by POP's time management, this way
  ! (instead of using dtt) half steps are correctly supported
  do while ( tsecond < tend - stepsize_next*0.5 .and. &
             errorCode == POP_Success )

    call timer_start(timer_step)
    call step(errorCode)
    call timer_stop(timer_step)

    !***
    !*** exit if energy is blowing
    !***
    if (check_KE(100.0_r8)) then
      call override_time_flag(fstop_now,value=.true.)
      call output_driver(errorCode)
      if (my_task == master_task) then
        write(6,*) 'aborting evolve because Ek > 100 '
        ret=-11
        return
      endif
    endif

    !-----------------------------------------------------------------------
    !
    ! write restart dumps and archiving
    !
    !-----------------------------------------------------------------------
    call output_driver(errorCode)

  enddo

  if (errorCode == POP_Success) then
    ret=0
  else
    ret=-2
  endif
end function

!-----------------------------------------------------------------------
!
! print timing information and clean up various environments if
! they have been used
!
!-----------------------------------------------------------------------
function cleanup_code() result(ret)
  integer :: ret

  !override time flag fstop_now and produce final output
  call override_time_flag(fstop_now,value=.true.)
  call output_driver(errorCode)

  !produce final output
  call timer_stop(timer_total)
  call timer_print_all(stats=.true.)

  call POP_ErrorPrint(errorCode, printTask=POP_masterTask)

  !call exit_POP(sigExit,'Successful completion of POP run')
  if (my_task == master_task) then
    write(6,*) 'Successful completion of POP run'
  endif

  ret=0
end function

!-----------------------------------------------------------------------
!
! Returns the elapsed time in the model in seconds
!
!-----------------------------------------------------------------------
function get_model_time(tout) result(ret)
  integer :: ret
  real(8), intent(out) :: tout

  tout = tsecond

  ret=0
end function

!-----------------------------------------------------------------------
!
! Returns the default number of seconds in a full time step
!
!-----------------------------------------------------------------------
function get_timestep(dtout) result(ret)
  integer :: ret
  real(8), intent(out) :: dtout

  dtout = dtt

  ret=0
end function

!-----------------------------------------------------------------------
!
! Returns number of seconds in the next step, can be less than default for half steps
!
!-----------------------------------------------------------------------
function get_timestep_next(dtout) result(ret)
  integer :: ret
  real(8), intent(out) :: dtout

  dtout = stepsize_next

  ret=0
end function

!-----------------------------------------------------------------------
!
! Getter and setter for wind stress per grid point
! Be sure to call prepare_wind_stress() before calling this
!
!-----------------------------------------------------------------------
function get_node_wind_stress(g_i, g_j, tau_x_, tau_y_, n) result(ret)
  integer :: ret,n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(out) :: tau_x_, tau_y_

  call get_gridded_variable_vector(g_i, g_j, tau_x, tau_x_, n)
  call get_gridded_variable_vector(g_i, g_j, tau_y, tau_y_, n)

  ret=0
end function

!----------------------------------------------------------------------
!
! This function converts SMF or SMFT to wind stress
! The result is stored in the internal variables tau_x and tau_y
! which can in turn be accessed by get_node_wind_stress()
!
!----------------------------------------------------------------------
function prepare_wind_stress() result(ret)
  integer :: ret

  tau_x =  SMF(:,:,1,:)/momentum_factor * cos(ANGLE) - SMF(:,:,2,:)/momentum_factor * sin(ANGLE)
  tau_y =  ( SMF(:,:,2,:)/momentum_factor + tau_x * sin(ANGLE) ) / cos (ANGLE)

  if (errorCode == POP_Success) then
    ret=0
  else
    ret=-1
  endif
end function
function set_node_wind_stress (g_i, g_j, tau_x_, tau_y_, n) result(ret)
  integer :: ret, n
  real*8, dimension(n), intent(in) :: tau_x_, tau_y_
  integer, dimension(n), intent(in) :: g_i, g_j ! global i and j indexes for the gridpoint

  call set_gridded_variable_vector(g_i, g_j, tau_x, tau_x_, n)
  call set_gridded_variable_vector(g_i, g_j, tau_y, tau_y_, n)

  fupdate_wind_stress = .true.

  ret=0
end function

function set_wind_stress() result(ret)
  integer :: ret

  fupdate_wind_stress = .false.

  !if we want to overwrite the wind stress, then we have to make sure that SMF is
  !not overwritten by some later interpolation routine, therefore, we have to
  !enforce the following settings
  ws_data_type = 'none'
  ws_data_next = never
  ws_data_update = never
  ws_interp_freq = 'never'
  ws_interp_next = never
  ws_interp_last = never
  ws_interp_inc  = c0

  ! rotate_wind_stress applies tau_x and tau_y to the U-grid
  ! variable SMF (surface momentum fluxes (wind stress))
  ! wind stress in N/m^2 is converted to vel flux (cm^2/s^2)
  ! the method expects tau_x and tau_y to be supplied for the U grid

  ! set_gridded_variable only sets grid points in the physical domain
  ! still need to update halo values
  call POP_HaloUpdate(tau_x(:,:,:), POP_haloClinic,  &
                      POP_gridHorzLocCenter,          &
                      POP_fieldKindVector, errorCode, &
                      fillValue = 0.0_r8)

  call POP_HaloUpdate(tau_y(:,:,:), POP_haloClinic,  &
                      POP_gridHorzLocCenter,          &
                      POP_fieldKindVector, errorCode, &
                      fillValue = 0.0_r8)

  call rotate_wind_stress(tau_x, tau_y)

  if (errorCode == POP_Success) then
    ret=0
  else
    ret=-1
  endif
end function

! rotate_wind_stress()
!   rotates true zonal/meridional wind stress into local
!   coordinates, converts to dyne/cm**2
!
! adapted from forcing_coupled.F90, but modified to:
! 1. not apply the land mask RCALC
! 2. to have tau_x and tau_y be supplied on the U-grid instead of the T-grid
subroutine rotate_wind_stress(WORK1, WORK2)

  real (r8), dimension(nx_block,ny_block,max_blocks_clinic), intent(in) ::   &
      WORK1, WORK2        ! contains tau_x and tau_y from coupler on U-grid

  integer :: errorCode

  !-----------------------------------------------------------------------
  !
  !  rotate and convert
  !
  !-----------------------------------------------------------------------

   SMF(:,:,1,:) = (WORK1(:,:,:)*cos(ANGLE(:,:,:)) +  &
                   WORK2(:,:,:)*sin(ANGLE(:,:,:)))*  &
                   momentum_factor
   SMF(:,:,2,:) = (WORK2(:,:,:)*cos(ANGLE(:,:,:)) -  &
                   WORK1(:,:,:)*sin(ANGLE(:,:,:)))*  &
                   momentum_factor

  !-----------------------------------------------------------------------
  !
  !  perform halo updates following the vector rotation
  !
  !-----------------------------------------------------------------------

  call POP_HaloUpdate(SMF(:,:,1,:),POP_haloClinic,  &
                      POP_gridHorzLocCenter,          &
                      POP_fieldKindVector, errorCode, &
                      fillValue = 0.0_POP_r8)

  call POP_HaloUpdate(SMF(:,:,2,:),POP_haloClinic,  &
                      POP_gridHorzLocCenter,          &
                      POP_fieldKindVector, errorCode, &
                      fillValue = 0.0_POP_r8)

end subroutine rotate_wind_stress

!-----------------------------------------------------------------------
!
! Generic getter and setters for gridded variables
!
!-----------------------------------------------------------------------
subroutine get_gridded_variable(g_i, g_j, grid, value)
  integer, intent(in) :: g_i, g_j
  real*8, intent(in), dimension(:,:,:) :: grid
  real*8, intent(out) :: value

  integer :: i,j,iblock
  type (block) :: this_block

  value = 0.0 !important for MPI_SUM used later

  ! search rather than iterate over all points
  do iblock=1, nblocks_clinic
    this_block = get_block(blocks_clinic(iblock),iblock)

    ! i_glob and j_glob denote the global index of gridpoint within a block
    ! the ghost cells are also given indices but they may have very different values on cyclic borders etc
    ! for now, only look at the grid points that are not ghost cells
    !
    ! nx_block and ny_block are the dimensions of the block
    ! nghost+1 is the first index within the block that is part of the physical domain
    ! nx_block-nghost is the last index within the block that is part of the physical domain
    if (this_block%i_glob(nghost+1) <= g_i .and. this_block%i_glob(nx_block-nghost) >= g_i .and. &
        this_block%j_glob(nghost+1) <= g_j .and. this_block%j_glob(ny_block-nghost) >= g_j ) then

      !find index in this block from global index (1+ because indexes start at 1 in Fortran)
      i = 1+nghost + g_i - this_block%i_glob(1+nghost)
      j = 1+nghost + g_j - this_block%j_glob(1+nghost)

      !debugging: check if this went ok
      !if (this_block%i_glob(i) /= g_i .or. this_block%j_glob(j) /= g_j) then
      !  write (*,*) 'Error: g_i =', g_i, ', g_j=', g_j, ' and found i=', this_block%i_glob(i), ' j=', this_block%j_glob(j)
      !endif

      value = grid(i,j,iblock)

    endif

  enddo

end subroutine get_gridded_variable

subroutine set_gridded_variable(g_i, g_j, grid, value)
  integer, intent(in) :: g_i, g_j
  real*8, intent(inout), dimension(:,:,:) :: grid
  real*8, intent(in) :: value

  integer :: i,j,iblock
  type (block) :: this_block

  ! search rather than iterate over all points
  do iblock=1, nblocks_clinic
    this_block = get_block(blocks_clinic(iblock),iblock)

    if (this_block%i_glob(nghost+1) <= g_i .and. this_block%i_glob(nx_block-nghost) >= g_i .and. &
        this_block%j_glob(nghost+1) <= g_j .and. this_block%j_glob(ny_block-nghost) >= g_j ) then

      i = 1+nghost + g_i - this_block%i_glob(1+nghost)
      j = 1+nghost + g_j - this_block%j_glob(1+nghost)

      !debugging: check if this went ok
      !if (this_block%i_glob(i) /= g_i .or. this_block%j_glob(j) /= g_j) then
      !  write (*,*) 'Error: g_i =', g_i, ', g_j=', g_j, ' and found i=', this_block%i_glob(i), ' j=', this_block%j_glob(j)
      !endif

      grid(i,j,iblock) = value

    endif

  enddo

end subroutine set_gridded_variable

subroutine get_gridded_variable_3D(g_i, g_j, k, grid, value)
  integer, intent(in) :: g_i, g_j, k
  real*8, intent(in), dimension(:,:,:,:) :: grid
  real*8, intent(out) :: value

  integer :: i,j,iblock
  type (block) :: this_block

  do iblock=1, nblocks_clinic
    this_block = get_block(blocks_clinic(iblock),iblock)
    if (this_block%i_glob(nghost+1) <= g_i .and. this_block%i_glob(nx_block-nghost) >= g_i .and. &
        this_block%j_glob(nghost+1) <= g_j .and. this_block%j_glob(ny_block-nghost) >= g_j ) then

      i = 1+nghost + g_i - this_block%i_glob(1+nghost)
      j = 1+nghost + g_j - this_block%j_glob(1+nghost)

      value = grid(i,j,k,iblock)

    endif
  enddo
end subroutine get_gridded_variable_3D
subroutine set_gridded_variable_3D(g_i, g_j, k, grid, value)
  integer, intent(in) :: g_i, g_j, k
  real*8, intent(inout), dimension(:,:,:,:) :: grid
  real*8, intent(in) :: value

  integer :: i,j,iblock
  type (block) :: this_block

  do iblock=1, nblocks_clinic
    this_block = get_block(blocks_clinic(iblock),iblock)
    if (this_block%i_glob(nghost+1) <= g_i .and. this_block%i_glob(nx_block-nghost) >= g_i .and. &
        this_block%j_glob(nghost+1) <= g_j .and. this_block%j_glob(ny_block-nghost) >= g_j ) then

      i = 1+nghost + g_i - this_block%i_glob(1+nghost)
      j = 1+nghost + g_j - this_block%j_glob(1+nghost)

      grid(i,j,k,iblock) = value
    endif
  enddo

end subroutine set_gridded_variable_3D

subroutine get_gather(g_i, g_j, grid, value_, n)
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(out) :: value_
  real*8, dimension(:,:,:), intent(inout) :: grid

  integer :: ii
  value_ = 0.0 !first zero the array

  call gather_global(WORK_G, grid, master_task, distrb_clinic)
  if (my_task == master_task) then
    do ii=1,n
      value_(ii) = WORK_G(g_i(ii),g_j(ii))
    enddo
  endif
end subroutine get_gather

subroutine get_gather_3D(g_i, g_j, k, grid, value_, n)
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j, k
  real*8, dimension(n), intent(out) :: value_
  real*8, dimension(:,:,:,:), intent(inout) :: grid

  integer :: ii, ki

  do ki=1,km
    if (ANY(k(:) == ki)) then
      call gather_global(WORK_G, grid(:,:,ki,:), master_task, distrb_clinic)
      if (my_task == master_task) then
        do ii=1,n
          if (k(ii) == ki) then
            value_(ii) = WORK_G(g_i(ii),g_j(ii))
          endif
        enddo
      endif
    endif
  enddo

end subroutine get_gather_3D

subroutine get_gridded_variable_vector(g_i, g_j, grid, value, n)
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, intent(in), dimension(:,:,:) :: grid
  real*8, dimension(n), intent(out) :: value

  integer :: ii,ierr

  include 'mpif.h'

  value = 0.0 !important for MPI_SUM used later

  do ii=1,n
    call get_gridded_variable(g_i(ii), g_j(ii), grid, value(ii))
  enddo

  !only the output of the node with MPI rank 0 is significant in AMUSE, reduce to single value per element
  if(my_task == master_task) then
    call MPI_REDUCE(MPI_IN_PLACE, value, n, MPI_DBL, MPI_SUM, master_task, MPI_COMM_OCN, ierr)
  else
    call MPI_REDUCE(value, 0, n, MPI_DBL, MPI_SUM, master_task, MPI_COMM_OCN, ierr)
  endif

end subroutine get_gridded_variable_vector

subroutine set_gridded_variable_vector(g_i, g_j, grid, value, n)
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, intent(inout), dimension(:,:,:) :: grid
  real*8, dimension(n), intent(in) :: value

  integer :: ii

  do ii=1,n
    call set_gridded_variable(g_i(ii), g_j(ii), grid, value(ii))
  enddo

end subroutine set_gridded_variable_vector

subroutine get_gridded_variable_vector_3D(g_i, g_j, k, grid, value, n)
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j, k
  real*8, intent(in), dimension(:,:,:,:) :: grid
  real*8, dimension(n), intent(out) :: value

  integer :: ii,ierr

  include 'mpif.h'

  value = 0.0 !important for MPI_SUM used later

  do ii=1,n
    call get_gridded_variable_3D(g_i(ii), g_j(ii), k(ii), grid, value(ii))
  enddo

  !only the output of the node with MPI rank 0 is significant in AMUSE, reduce to single value per element
  if(my_task == master_task) then
    call MPI_REDUCE(MPI_IN_PLACE, value, n, MPI_DBL, MPI_SUM, master_task, MPI_COMM_OCN, ierr)
  else
    call MPI_REDUCE(value, 0, n, MPI_DBL, MPI_SUM, master_task, MPI_COMM_OCN, ierr)
  endif
end subroutine get_gridded_variable_vector_3D

subroutine set_gridded_variable_vector_3D(g_i, g_j, k, grid, value, n)
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j, k
  real*8, intent(inout), dimension(:,:,:,:) :: grid
  real*8, dimension(n), intent(in) :: value
  integer :: ii

  do ii=1,n
    call set_gridded_variable_3D(g_i(ii), g_j(ii), k(ii), grid, value(ii))
  enddo

end subroutine set_gridded_variable_vector_3D

!-----------------------------------------------------------------------
!
! Getter and setter for Coriolis Force
!
! these are currently implemented using the FCOR on the U grid
! set_coriolis_f() can be used to update the FCORT on the T grid based
! on the modified FCOR for the U grid
!
!-----------------------------------------------------------------------
function get_node_coriolis_f(g_i, g_j, corif_, n) result(ret)
  integer :: ret, n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(out) :: corif_

  if (initialized .eqv. .false.) then
    call exit_POP(sigAbort, 'Error: get_node_coriolis_f() called before initialize_code()')
  endif

  call get_gridded_variable_vector(g_i, g_j, FCOR, corif_, n)

  ret=0
end function
function set_node_coriolis_f(g_i, g_j, corif_, n) result(ret)
  integer :: ret, n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(in) :: corif_

  call set_gridded_variable_vector(g_i, g_j, FCOR, corif_, n)

  fupdate_coriolis = .true.

  ret=0
end function

! set_coriolis_f updates FCORT (T-grid) based on FCOR (U-grid)
function set_coriolis_f() result(ret)
  integer :: ret
  integer :: iblock

  fupdate_coriolis = .false.

  !first update ghost cells for FCOR on U-grid
  call POP_HaloUpdate(FCOR, POP_haloClinic,  &
                      POP_gridHorzLocCenter,          &
                      POP_fieldKindVector, errorCode, &
                      fillValue = 0.0_r8)

  !convert to T-grid
  do iblock=1, nblocks_clinic
    call ugrid_to_tgrid(FCORT, FCOR, iblock)
  enddo

  !update halo cells on T-grid
  call POP_HaloUpdate(FCORT, POP_haloClinic,  &
                      POP_gridHorzLocCenter,          &
                      POP_fieldKindVector, errorCode, &
                      fillValue = 0.0_r8)

  if (errorCode == POP_Success) then
    ret=0
  else
    ret=-1
  endif
end function

!-----------------------------------------------------------------------
!
! Recommit forcings will call all functions that had forcings set to
! temporary locations and will ensure these are properly converted to
! internal variables used by POP
!
!-----------------------------------------------------------------------
function recommit_forcings() result(ret)
  integer :: ret
  ret = 0

  if (fupdate_wind_stress) then
    ret = set_wind_stress()
  endif

  if (ret /= 0) return

  if (fupdate_coriolis) then
    ret = set_coriolis_f()
  endif
end function

!-----------------------------------------------------------------------
!
!  Getters for node and element surface state
!
!-----------------------------------------------------------------------
function get_node_barotropic_vel(g_i, g_j, uvel_, vvel_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(out) :: uvel_, vvel_

  if (n < nx_global*ny_global) then
    call get_gridded_variable_vector(g_i, g_j, UBTROP(:,:,curtime,:), uvel_, n)
    call get_gridded_variable_vector(g_i, g_j, VBTROP(:,:,curtime,:), vvel_, n)
  else
    call get_gather(g_i, g_j, UBTROP(:,:,curtime,:), uvel_, n)
    call get_gather(g_i, g_j, VBTROP(:,:,curtime,:), vvel_, n)
  endif

  ret=0
end function
function set_node_barotropic_vel(g_i, g_j, uvel_, vvel_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(in) :: uvel_, vvel_

  if (n < nx_global*ny_global) then
    call set_gridded_variable_vector(g_i, g_j, UBTROP(:,:,curtime,:), uvel_, n)
    call set_gridded_variable_vector(g_i, g_j, VBTROP(:,:,curtime,:), vvel_, n)
    call set_gridded_variable_vector(g_i, g_j, UBTROP(:,:,oldtime,:), uvel_, n)
    call set_gridded_variable_vector(g_i, g_j, VBTROP(:,:,oldtime,:), vvel_, n)
  else
    !call get_gather(g_i, g_j, UBTROP(:,:,curtime,:), uvel_, n)
    !call get_gather(g_i, g_j, VBTROP(:,:,curtime,:), vvel_, n)
  endif

  ret=0
end function
function get_node_surface_state(g_i, g_j, ssh_, uvel_, vvel_,gradx_,grady_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(out) :: ssh_, uvel_, vvel_, gradx_, grady_

  if (n < nx_global*ny_global) then
    call get_gridded_variable_vector(g_i, g_j, PSURF(:,:,curtime,:), ssh_, n)
    call get_gridded_variable_vector(g_i, g_j, GRADPX(:,:,curtime,:), gradx_, n)
    call get_gridded_variable_vector(g_i, g_j, GRADPY(:,:,curtime,:), grady_, n)
    ssh_ = ssh_ / grav
    gradx_ = gradx_ / grav
    grady_ = grady_ / grav
    call get_gridded_variable_vector(g_i, g_j, UVEL(:,:,1,curtime,:), uvel_, n)
    call get_gridded_variable_vector(g_i, g_j, VVEL(:,:,1,curtime,:), vvel_, n)
  else
    call get_gather(g_i, g_j, PSURF(:,:,curtime,:), ssh_, n)
    ssh_ = ssh_ / grav
    call get_gather(g_i, g_j, UVEL(:,:,1,curtime,:), uvel_, n)
    call get_gather(g_i, g_j, VVEL(:,:,1,curtime,:), vvel_, n)
  endif

  ret=0
end function
function set_node_surface_state(g_i, g_j, ssh_, gradx_, grady_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(in) :: ssh_, gradx_, grady_

  if (n < nx_global*ny_global) then
    call set_gridded_variable_vector(g_i, g_j, PSURF(:,:,curtime,:), ssh_, n)
    call set_gridded_variable_vector(g_i, g_j, GRADPX(:,:,curtime,:), gradx_, n)
    call set_gridded_variable_vector(g_i, g_j, GRADPY(:,:,curtime,:), grady_, n)
    call set_gridded_variable_vector(g_i, g_j, PSURF(:,:,oldtime,:), ssh_, n)
    call set_gridded_variable_vector(g_i, g_j, GRADPX(:,:,oldtime,:), gradx_, n)
    call set_gridded_variable_vector(g_i, g_j, GRADPY(:,:,oldtime,:), grady_, n)
    PSURF=PSURF*grav
    GRADPX=GRADPX*grav
    GRADPY=GRADPY*grav

    PGUESS=PSURF(:,:,1,:)
  endif

  ret=0
end function
function get_element_surface_state(g_i, g_j, temp_, salt_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(out) :: temp_, salt_

  if (my_task == master_task) then
    write (*,*) 'get_element_surface_state() called with n=', n
  endif

  if (n < nx_global*ny_global) then
    call get_gridded_variable_vector(g_i, g_j, TRACER(:,:,1,1,curtime,:), temp_, n)
    call get_gridded_variable_vector(g_i, g_j, TRACER(:,:,1,2,curtime,:), salt_, n)
  else
    call get_gather(g_i, g_j, TRACER(:,:,1,1,curtime,:), temp_, n)
    call get_gather(g_i, g_j, TRACER(:,:,1,2,curtime,:), salt_, n)
  endif

  ret=0
end function

function get_element_surface_heat_flux(g_i, g_j, shf_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(out) :: shf_

  real*8, dimension(nx_block, ny_block, max_blocks_clinic) :: WORK1
  integer :: iblock

  do iblock=1, nblocks_clinic
    where (KMT(:,:,iblock) > 0)
      WORK1(:,:,iblock) = (STF(:,:,1,iblock)+SHF_QSW(:,:,iblock))/hflux_factor ! W/m^2
    elsewhere
      WORK1(:,:,iblock) = c0
    end where
  end do

  call get_gridded_variable_vector(g_i, g_j, WORK1, shf_, n)

  ret=0
end function

!-----------------------------------------------------------------------
!
! Getters for grid info
!
! Nodes are on the U grid
! Elements on the T grid
!
!-----------------------------------------------------------------------
function get_node_position(g_i, g_j, lat_, lon_, n) result(ret)
  integer :: ret,n,ii
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(out) :: lat_, lon_

!  real :: time
  integer :: ierr

!  if (my_task == master_task) then
!    write (*,*) 'get_node_position() called n=', n
!  endif

!  if (n < nx_global*ny_global) then
!    call get_gridded_variable_vector(g_i, g_j, ULAT, lat_, n)
!    call get_gridded_variable_vector(g_i, g_j, ULON, lon_, n)
!  else

!  time = 0.0
!  call MPI_Barrier(MPI_COMM_OCN, ierr)
!  call start_timer
!   call get_gather(g_i, g_j, ULAT, lat_, n)
!  call MPI_Barrier(MPI_COMM_OCN, ierr)
!  call stop_timer(time)

!  if (my_task == master_task) then
!    write(*,*) 'get_gather took: ', time, 'ms .'
!  endif

!  time = 0.0
!  call MPI_Barrier(MPI_COMM_OCN, ierr)
!  call start_timer
!  call get_gridded_variable_vector(g_i, g_j, ULAT, lat_, n)
!  call MPI_Barrier(MPI_COMM_OCN, ierr)
!  call stop_timer(time)

!  if (my_task == master_task) then
!    write(*,*) 'get_gridded_variable_vector took: ', time, ' ms.'
!  endif
!   call get_gather(g_i, g_j, ULON, lon_, n)

  if (my_task == master_task) then
    do ii=1,n
      lon_(ii) = ULON_G(g_i(ii),g_j(ii))
      lat_(ii) = ULAT_G(g_i(ii),g_j(ii))
    enddo
  endif

!  endif

  ret=0
end function

function get_element_position(g_i, g_j, lat_, lon_, n) result(ret)
  integer :: ret,n
  integer :: ii
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(out) :: lat_, lon_

  !if (n < nx_global*ny_global) then
  !  call get_gridded_variable_vector(g_i, g_j, TLAT, lat_, n)
  !  call get_gridded_variable_vector(g_i, g_j, TLON, lon_, n)
  !else
  ! call get_gather(g_i, g_j, TLAT, lat_, n)
  ! call get_gather(g_i, g_j, TLON, lon_, n)
  !endif
  if (my_task == master_task) then
    do ii=1,n
      lon_(ii) = TLON_G(g_i(ii),g_j(ii))
      lat_(ii) = TLAT_G(g_i(ii),g_j(ii))
    enddo
  endif

  ret=0
end function

function get_node_vposition(g_i, g_j, k, depth_, n) result(ret)
  integer :: ret,n
  integer, dimension(n), intent(in) :: g_i, g_j, k
  real*8, dimension(n), intent(out) :: depth_

  ret=0
  if (partial_bottom_cells) then
    call get_gridded_variable_vector_3D(g_i, g_j, k, DZU, depth_, n)
  else
    ret = get_zt(k, depth_, n)
  endif

end function

function get_element_vposition(g_i, g_j, k, depth_, n) result(ret)
  integer :: ret,n
  integer, dimension(n), intent(in) :: g_i, g_j, k
  real*8, dimension(n), intent(out) :: depth_

  ret=0
  if (partial_bottom_cells) then
    call get_gridded_variable_vector_3D(g_i, g_j, k, DZT, depth_, n)
  else
    ret = get_zt(k, depth_, n)
  endif

end function

function get_number_of_nodes(num) result(ret)
  integer :: ret
  integer, intent(out) :: num
  num = nx_global * ny_global
  ret=0
end function

function get_domain_size(x_, y_) result(ret)
  integer :: ret
  integer, intent(out) :: x_, y_
  x_ = nx_global
  y_ = ny_global
  ret=0
end function

function get_number_of_vertical_levels(km_) result(ret)
  integer :: ret
  integer, intent(out) :: km_
  km_ = km
  ret=0
end function

function get_dz(k, dz_) result(ret)
  integer :: ret
  integer, intent(in) :: k
  real*8,  intent(out) :: dz_
  dz_=dz(k)
  ret=0
end function

function set_dz(k, dz_) result(ret)
  integer :: ret
  integer, intent(in) :: k
  real*8, intent(in) :: dz_
  dz(k)=dz_
  ret=0
end function

function get_node_depth(g_i, g_j, depth_, n) result(ret)
  integer :: ret,n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(out) :: depth_

  if (n < nx_global*ny_global) then
    call get_gridded_variable_vector(g_i, g_j, HU, depth_, n)
  else
    call get_gather(g_i, g_j, HU, depth_, n)
  endif

  ret=0
end function

function get_element_depth(g_i, g_j, depth_, n) result(ret)
  integer :: ret,n
  integer, dimension(n), intent(in) :: g_i, g_j
  real*8, dimension(n), intent(out) :: depth_

  if (n < nx_global*ny_global) then
    call get_gridded_variable_vector(g_i, g_j, HT, depth_, n)
  else
    call get_gather(g_i, g_j, HT, depth_, n)
  endif

  ret=0
end function

function set_KMT(g_i,g_j, KMT_, n) result(ret)
  integer :: i,ret,n
  integer, dimension(n), intent(in) :: g_i, g_j
  integer, dimension(n), intent(in) :: KMT_
  do i=1,n
      KMT_G(g_i(i), g_j(i))=KMT_(i)
  enddo

  ret=0
end function

function get_KMT(g_i,g_j, KMT_, n) result(ret)
  integer :: i,ret,n
  integer, dimension(n), intent(in) :: g_i, g_j
  integer, dimension(n), intent(out) :: KMT_

  do i=1,n
      KMT_(i)=KMT_G(g_i(i), g_j(i))
  enddo

  ret=0
end function

function get_zt(k, zt_, n) result(ret)
  integer :: ret,n,i
  integer, dimension(n), intent(in) :: k
  real*8, dimension(n), intent(out) :: zt_

  zt_(1:n)=zt(k(1:n))

  ret=0
end function

!-----------------------------------------------------------------------
!
! Getters and setters for individual 3D fields
! this code was written optimistically and probably needs adjustment later
!
!-----------------------------------------------------------------------
function get_element3d_temperature(i, j, k, temp_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: i, j, k
  real*8, dimension(n), intent(out) :: temp_

!  real*4 :: time
  integer :: ierr

  if (my_task == master_task) then
    write (*,*) 'get_element3d_temperature() called with n=', n
  endif

!  time = 0.0
!  call MPI_Barrier(MPI_COMM_OCN, ierr)
!  call start_timer
!  call get_gather_3D(i, j, k, TRACER(:,:,:,1,curtime,:), temp_, n)

!  call MPI_Barrier(MPI_COMM_OCN, ierr)
!  call stop_timer(time)

!  if (my_task == master_task) then
!    write(*,*) 'get_gather_3D took: ', time, 'ms .'
!  endif

!  time = 0.0
!  call MPI_Barrier(MPI_COMM_OCN, ierr)
!  call start_timer
  call get_gridded_variable_vector_3D(i, j, k, TRACER(:,:,:,1,curtime,:), temp_, n)

!  call MPI_Barrier(MPI_COMM_OCN, ierr)
!  call stop_timer(time)

!  if (my_task == master_task) then
!    write(*,*) 'get_gridded_variable_vector_3D took: ', time, ' ms.'
!  endif

  ret=0
end function
function set_element3d_temperature(i, j, k, temp_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: i, j, k
  real*8, dimension(n), intent(in) :: temp_

  call set_gridded_variable_vector_3D(i, j, k, TRACER(:,:,:,1,curtime,:), temp_, n)
  call set_gridded_variable_vector_3D(i, j, k, TRACER(:,:,:,1,oldtime,:), temp_, n)

  ret=0
end function
function get_element3d_salinity(i, j, k, salt_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: i, j, k
  real*8, dimension(n), intent(out) :: salt_

  call get_gridded_variable_vector_3D(i, j, k, TRACER(:,:,:,2,curtime,:), salt_, n)
!  call get_gather_3D(i, j, k, TRACER(:,:,:,2,curtime,:), salt_, n)

  ret=0
end function
function set_element3d_salinity(i, j, k, salt_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: i, j, k
  real*8, dimension(n), intent(in) :: salt_

  call set_gridded_variable_vector_3D(i, j, k, TRACER(:,:,:,2,curtime,:), salt_, n)
  call set_gridded_variable_vector_3D(i, j, k, TRACER(:,:,:,2,oldtime,:), salt_, n)

  ret=0
end function

function get_node3d_velocity_xvel(i, j, k, uvel_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: i, j, k
  real*8, dimension(n), intent(out) :: uvel_

  call get_gridded_variable_vector_3D(i, j, k, UVEL(:,:,:,curtime,:), uvel_, n)
!  call get_gather_3D(i, j, k, UVEL(:,:,:,curtime,:), uvel_, n)

  ret=0
end function
function set_node3d_velocity_xvel(i, j, k, uvel_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: i, j, k
  real*8, dimension(n), intent(in) :: uvel_

  call set_gridded_variable_vector_3D(i, j, k, UVEL(:,:,:,curtime,:), uvel_, n)
  call set_gridded_variable_vector_3D(i, j, k, UVEL(:,:,:,oldtime,:), uvel_, n)

  ret=0
end function
function get_node3d_velocity_yvel(i, j, k, vvel_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: i, j, k
  real*8, dimension(n), intent(out) :: vvel_

  call get_gridded_variable_vector_3D(i, j, k, VVEL(:,:,:,curtime,:), vvel_, n)
!  call get_gather_3D(i, j, k, VVEL(:,:,:,curtime,:), vvel_, n)

  ret=0
end function
function set_node3d_velocity_yvel(i, j, k, vvel_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: i, j, k
  real*8, dimension(n), intent(in) :: vvel_

  call set_gridded_variable_vector_3D(i, j, k, VVEL(:,:,:,curtime,:), vvel_, n)
  call set_gridded_variable_vector_3D(i, j, k, VVEL(:,:,:,oldtime,:), vvel_, n)

  ret=0
end function

function get_node3d_velocity_zvel(i, j, k, wvel_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: i, j, k
  real*8, dimension(n), intent(out) :: wvel_

  call get_gridded_variable_vector_3D(i, j, k, WVEL(:,:,:,:), wvel_, n)

  ret=0
end function

function get_element3d_density(i, j, k, rho_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: i, j, k
  real*8, dimension(n), intent(out) :: rho_

  call get_gridded_variable_vector_3D(i, j, k, RHO(:,:,:,curtime,:), rho_, n)
!  call get_gather_3D(i, j, k, RHO(:,:,:,curtime,:), rho_, n)

  ret=0
end function
function set_element3d_density(i, j, k, rho_, n) result (ret)
  integer :: ret
  integer, intent(in) :: n
  integer, dimension(n), intent(in) :: i, j, k
  real*8, dimension(n), intent(in) :: rho_

  call set_gridded_variable_vector_3D(i, j, k, RHO(:,:,:,curtime,:), rho_, n)
  call set_gridded_variable_vector_3D(i, j, k, RHO(:,:,:,oldtime,:), rho_, n)

  ret=0
end function

!-----------------------------------------------------------------------
!
! State transition functions
!
! Currently these both only call one internal routine, but this is likely
! to be extended in the future
!
!-----------------------------------------------------------------------
function recommit_parameters() result (ret)
  integer :: ret
  ret=0

  ret = recommit_forcings()

end function
function prepare_parameters() result (ret)
  integer :: ret
  ret=0

  if (initialized .eqv. .false.) then
    call exit_POP(sigAbort, 'Error: prepare_parameters() called before initialize_code()')
  endif

  ret = prepare_wind_stress()

  ret = prepare_vertical_velocity()

end function

function prepare_vertical_velocity() result (ret)
  integer :: ret

   real (r8), allocatable, dimension(:,:,:) :: &
      WVELT   ! vertical velocity at T-points

   type (block) :: &
     this_block  ! block info for current block

   integer(int_kind) :: iblock, k

   allocate (WVELT(nx_block,ny_block,km))

   WVELT = c0

   do iblock = 1, nblocks_clinic

      this_block = get_block(blocks_clinic(iblock),iblock)

      call wcalc(WVELT, UVEL(:,:,:,curtime,iblock),   &
                        VVEL(:,:,:,curtime,iblock), this_block)

      do k = 1, km
         call tgrid_to_ugrid(WVEL(:,:,k,iblock), WVELT(:,:,k), iblock)
      enddo

   enddo

   deallocate (WVELT)

  ret = 0
end function

!-----------------------------------------------------------------------
!
! Getters and settings for parameters
!
!-----------------------------------------------------------------------
function get_horiz_grid_option(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = horiz_grid_opt

  ret=0
end function
function set_horiz_grid_option(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'file' .OR. option == 'internal' .OR. option == 'amuse') then
    horiz_grid_opt = option
  else
    ret=-1
  endif
end function
function get_horiz_grid_file(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = horiz_grid_file

  ret=0
end function
function set_horiz_grid_file(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  horiz_grid_opt = 'file'
  horiz_grid_file = option
end function

function get_vert_grid_option(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = vert_grid_opt

  ret=0
end function
function set_vert_grid_option(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'file' .OR. option == 'internal' .OR. option=='amuse') then
    vert_grid_opt = option
  else
    ret=-1
  endif
end function
function get_vert_grid_file(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = vert_grid_file

  ret=0
end function
function set_vert_grid_file(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  vert_grid_opt = 'file'
  vert_grid_file = option
end function

function get_topography_option(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = topography_opt

  ret=0
end function
function set_topography_option(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'file' .OR. option == 'internal' .OR. option=='amuse') then
    topography_opt = option
  else
    ret=-1
  endif
end function
function get_topography_file(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = topography_file

  ret=0
end function
function set_topography_file(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  topography_opt = 'file'
  topography_file = option
end function
function get_bottom_cell_file(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = bottom_cell_file

  ret=0
end function
function set_bottom_cell_file(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  partial_bottom_cells = .true.
  bottom_cell_file = option
end function

function get_ts_option(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = init_ts_option

  ret=0
end function
function set_ts_option(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'restart' .OR. option == 'internal') then
    init_ts_option = option
  else
    ret=-1
  endif
end function
function get_ts_file(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = init_ts_file

  ret=0
end function
function set_ts_file(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  init_ts_option = 'restart'
  init_ts_file = option

  ! prevent that this setting can be overwritten by a pointer file
  luse_pointer_files = .false.
end function
function get_ts_file_format(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = init_ts_file_fmt

  ret=0
end function
function set_ts_file_format(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'bin' .OR. option == 'nc') then
    init_ts_file_fmt = option
  else
    ret=-1
  endif
end function

function set_nprocs(nprocs) result (ret)
  integer :: ret
  integer, intent(in) :: nprocs
  ret=0

  nprocs_clinic = nprocs
  nprocs_tropic = nprocs
end function

function get_distribution(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = clinic_distribution_type

  ret=0
end function
function set_distribution(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'cartesian' .OR. option == 'predefined') then
    clinic_distribution_type = option
    tropic_distribution_type = option
  else
    ret=1
  endif
end function
function get_distribution_file(filename) result (ret)
  integer :: ret
  character (char_len), intent(out) :: filename
  ret=0

  filename = distribution_file
end function
function set_distribution_file(filename) result (ret)
  integer :: ret
  character (char_len), intent(in) :: filename
  ret=0

  distribution_file = filename
  clinic_distribution_type = 'predefined'
  tropic_distribution_type = 'predefined'
end function

function get_ew_boundary_type(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = ew_boundary_type

  ret=0
end function
function set_ew_boundary_type(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'closed' .OR. option == 'cyclic') then
    ew_boundary_type = option
  else
    ret=1
  endif
end function
function get_ns_boundary_type(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = ns_boundary_type

  ret=0
end function
function set_ns_boundary_type(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'closed' .OR. option == 'cyclic' .OR. option == 'tripole') then
    ns_boundary_type = option
  else
    ret=1
  endif
end function

function get_restart_option(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = restart_freq_opt

  ret=0
end function
function set_restart_option(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'never' .OR. option == 'nyear' .OR. option == 'nmonth' &
      .OR. option == 'nday' .OR. option == 'nhour' .OR. option == 'nstep') then
    restart_freq_opt = option
  else
    ret=1
  endif
end function
function get_restart_freq_option(option) result (ret)
  integer :: ret
  integer, intent(out) :: option

  option = restart_freq

  ret=0
end function
function set_restart_freq_option(option) result (ret)
  integer :: ret
  integer, intent(in) :: option
  ret=0

  restart_freq = option
end function
function get_restart_file(filename) result (ret)
  integer :: ret
  character (char_len), intent(out) :: filename

  filename = restart_outfile

  ret=0
end function
function set_restart_file(filename) result (ret)
  integer :: ret
  character (char_len), intent(in) :: filename
  ret=0

  restart_outfile = filename
end function

function get_tavg_option(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = tavg_freq_opt

  ret=0
end function
function set_tavg_option(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'never' .OR. option == 'nyear' .OR. option == 'nmonth' &
      .OR. option == 'nday' .OR. option == 'nhour' .OR. option == 'nstep') then
    tavg_freq_opt = option
  else
    ret=1
  endif
end function
function get_tavg_freq_option(option) result (ret)
  integer :: ret
  integer, intent(out) :: option

  option = tavg_freq

  ret=0
end function
function set_tavg_freq_option(option) result (ret)
  integer :: ret
  integer, intent(in) :: option
  ret=0

  tavg_freq = option
end function
function get_tavg_file(filename) result (ret)
  integer :: ret
  character (char_len), intent(out) :: filename

  filename = tavg_outfile

  ret=0
end function
function set_tavg_file(filename) result (ret)
  integer :: ret
  character (char_len), intent(in) :: filename
  ret=0

  tavg_outfile = filename
end function

function get_movie_option(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = movie_freq_opt

  ret=0
end function
function set_movie_option(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'never' .OR. option == 'nyear' .OR. option == 'nmonth' &
      .OR. option == 'nday' .OR. option == 'nhour' .OR. option == 'nstep') then
    movie_freq_opt = option
  else
    ret=1
  endif
end function
function get_movie_freq_option(option) result (ret)
  integer :: ret
  integer, intent(out) :: option

  option = movie_freq

  ret=0
end function
function set_movie_freq_option(option) result (ret)
  integer :: ret
  integer, intent(in) :: option
  ret=0

  movie_freq = option
end function
function get_movie_file(filename) result (ret)
  integer :: ret
  character (char_len), intent(out) :: filename

  filename = movie_outfile

  ret=0
end function
function set_movie_file(filename) result (ret)
  integer :: ret
  character (char_len), intent(in) :: filename
  ret=0

  movie_outfile = filename
end function

function get_runid(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = runid

  ret=0
end function
function set_runid(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  runid = option
end function
function get_dt_option(option) result (ret)
  integer :: ret
  character (char_len), intent(out) :: option

  option = dt_option

  ret=0
end function
function set_dt_option(option) result (ret)
  integer :: ret
  character (char_len), intent(in) :: option
  ret=0

  if (option == 'auto_dt' .OR. option == 'steps_per_year' .OR. option == 'steps_per_day' &
      .OR. option == 'seconds' .OR. option == 'hours') then
    dt_option = option
  else
    ret=1
  endif
end function
function get_dt_count(option) result (ret)
  integer :: ret
  integer, intent(out) :: option

  option = dt_count

  ret=0
end function
function set_dt_count(option) result (ret)
  integer :: ret
  integer, intent(in) :: option
  ret=0

  dt_count = option
end function

function change_directory(pathname) result (ret)
  integer :: ret
  character (char_len), intent(in) :: pathname

  call CHDIR(pathname)
  ret=0
end function

function set_shf_data_type(type_) result (ret)
  integer :: ret
  character (char_len), intent(in) :: type_
  ret=0
  if (type_ == 'file')then
    shf_data_type = type_
  elseif(type_ == 'amuse' .or. type_ == 'analytic') then
    shf_data_type = type_
    shf_formulation = 'restoring'
    shf_interp_freq = 'every-timestep'
    shf_interp_type = 'linear'
  else
    ret=-1
  endif
end function

function get_shf_filename(filename) result (ret)
  integer :: ret
  character (char_len), intent(out) :: filename
  filename = shf_filename
  ret=0
end function
function get_shf_data_type(type_) result (ret)
  integer :: ret
  character (char_len), intent(out) :: type_
  type_ = shf_data_type
  ret=0
end function
function set_shf_monthly_file(filename) result (ret)
  integer :: ret
  character (char_len), intent(in) :: filename
  shf_data_type   = 'monthly'
  shf_interp_freq = 'every-timestep'
  shf_interp_type = 'linear'
  shf_filename    = filename
  ret=0
end function

function set_sfwf_data_type(type_) result (ret)
  integer :: ret
  character (char_len), intent(in) :: type_
  ret=0
  if (type_ == 'file')then
    shf_data_type = type_
  elseif(type_ == 'amuse' .or. type_ == 'analytic') then
    sfwf_data_type = type_
    sfwf_formulation = 'restoring'
    sfwf_interp_freq = 'every-timestep'
    sfwf_interp_type = 'linear'
  else
    ret=-1
  endif
end function
function get_sfwf_filename(filename) result (ret)
  integer :: ret
  character (char_len), intent(out) :: filename
  filename = sfwf_filename
  ret=0
end function
function get_sfwf_data_type(type_) result (ret)
  integer :: ret
  character (char_len), intent(out) :: type_
  type_ = sfwf_data_type
  ret=0
end function
function set_sfwf_monthly_file(filename) result (ret)
  integer :: ret
  character (char_len), intent(in) :: filename
  sfwf_data_type   = 'monthly'
  sfwf_interp_freq = 'every-timestep'
  sfwf_interp_type = 'linear'
  sfwf_filename    = filename
  ret=0
end function

!imposed freshwater flux, only signifcant when ladjust_precip = .true.
!value is in Sverdrups
function get_fwf_imposed(fwf_) result (ret)
  integer :: ret
  real*8, intent(out) :: fwf_
  fwf_ = fwf_imposed
  ret=0
end function
function set_fwf_imposed(fwf_) result (ret)
  integer :: ret
  real*8, intent(in) :: fwf_
  fwf_imposed = fwf_
  ret=0
end function

function get_ws_filename(filename) result (ret)
  integer :: ret
  character (char_len), intent(out) :: filename
  filename = ws_filename
  ret=0
end function
function get_ws_data_type(type_) result (ret)
  integer :: ret
  character (char_len), intent(out) :: type_
  type_ = ws_data_type
  ret=0
end function
function set_ws_data_type(type_) result (ret)
  integer :: ret
  character (char_len), intent(in) :: type_
  ws_data_type=trim(type_)
  ret=0
end function
function set_ws_monthly_file(filename) result (ret)
  integer :: ret
  character (char_len), intent(in) :: filename
  ws_data_type    = 'monthly'
  ws_interp_freq  = 'every-timestep'
  ws_interp_type  = 'linear'
  ws_filename = filename
  ret=0
end function

function get_namelist_filename(filename) result (ret)
  integer :: ret
  character (char_len), intent(out) :: filename
  filename = nml_filename
  ret=-1
end function
function set_namelist_filename(filename) result (ret)
  integer :: ret
  character (char_len), intent(in) :: filename
  nml_filename = filename
  ret=-1
end function

! this routine was created because, for coupling purposes, it is important
! that the lon,lat positions of the complete grid can be requested, including
! the land-only blocks not present in the rest of the POP simulation
subroutine initialize_global_grid

    select case (horiz_grid_opt)
    case ('internal')
      call horiz_grid_internal(.true.)
    case ('amuse')
      call horiz_grid_amuse(.true.)
    case ('file')
      call broadcast_scalar(horiz_grid_file, master_task)
      call read_horiz_grid(horiz_grid_file,.true.)
    case default
      call exit_POP(sigAbort,'ERROR: unknown horizontal grid option')
    end select

    !read_horiz_grid allocates ULAT_G and ULON_G on all nodes
    !deallocate on all but the master
    if (my_task /= master_task) then
        deallocate(ULAT_G, ULON_G)
    endif

    !compute the lat,lon of T points on master
    if (my_task == master_task) then
        allocate (TLAT_G(nx_global,ny_global), &
              TLON_G(nx_global,ny_global))

        call calc_tpoints_global
    endif
end subroutine initialize_global_grid

! copied and modified from grid.F90 to work for global grid
subroutine calc_tpoints_global
! !DESCRIPTION:
!  Calculates lat/lon coordinates of T points from U points
!  using a simple average of four neighbors in Cartesian 3d space.
!
   integer (POP_i4) :: i,j,n

   real (POP_r8) ::                   &
      xc,yc,zc,xs,ys,zs,xw,yw,zw, &! Cartesian coordinates for
      xsw,ysw,zsw,tx,ty,tz,da      !    nbr points

!-----------------------------------------------------------------------
!
!  TLAT_G, TLON_G are southwest 4-point averages of ULAT_G,ULON_G
!  for general grids, must drop into 3-d Cartesian space to prevent
!  problems near the pole
!
!-----------------------------------------------------------------------

    TLAT_G=0
    TLON_G=0

    do j=2,ny_global
    do i=2,nx_global

         !***
         !*** convert neighbor U-cell coordinates to 3-d Cartesian coordinates
         !*** to prevent problems with averaging near the pole
         !***

         zsw = cos(ULAT_G(i-1,j-1))
         xsw = cos(ULON_G(i-1,j-1))*zsw
         ysw = sin(ULON_G(i-1,j-1))*zsw
         zsw = sin(ULAT_G(i-1,j-1))

         zs  = cos(ULAT_G(i  ,j-1))
         xs  = cos(ULON_G(i  ,j-1))*zs
         ys  = sin(ULON_G(i  ,j-1))*zs
         zs  = sin(ULAT_G(i  ,j-1))

         zw  = cos(ULAT_G(i-1,j  ))
         xw  = cos(ULON_G(i-1,j  ))*zw
         yw  = sin(ULON_G(i-1,j  ))*zw
         zw  = sin(ULAT_G(i-1,j  ))

         zc  = cos(ULAT_G(i  ,j  ))
         xc  = cos(ULON_G(i  ,j  ))*zc
         yc  = sin(ULON_G(i  ,j  ))*zc
         zc  = sin(ULAT_G(i  ,j  ))

         !***
         !*** straight 4-point average to T-cell Cartesian coords
         !***

         tx = p25*(xc + xs + xw + xsw)
         ty = p25*(yc + ys + yw + ysw)
         tz = p25*(zc + zs + zw + zsw)

         !***
         !*** convert to lat/lon in radians
         !***

         da = sqrt(tx**2 + ty**2 + tz**2)

         TLAT_G(i,j) = asin(tz/da)

         if (tx /= c0 .or. ty /= c0) then
            TLON_G(i,j) = atan2(ty,tx)
         else
            TLON_G(i,j) = c0
         endif

    end do
    end do

    !***
    !*** for bottom row of domain where sw 4pt average is not valid,
    !*** extrapolate from interior
    !*** NOTE: THIS ASSUMES A CLOSED SOUTH BOUNDARY - WILL NOT
    !***       WORK CORRECTLY FOR CYCLIC OPTION
    !***

    do i=1,nx_global
       TLON_G(i,1) = TLON_G(i,2)
       TLAT_G(i,1) = c2*TLAT_G(i,2) - TLAT_G(i,3)
    end do

    where (TLON_G(:,:) > pi2) TLON_G(:,:) = TLON_G(:,:) - pi2
    where (TLON_G(:,:) < c0 ) TLON_G(:,:) = TLON_G(:,:) + pi2

    where (TLON_G(:,:) > pi2) TLON_G(:,:) = TLON_G(:,:) - pi2
    where (TLON_G(:,:) < c0 ) TLON_G(:,:) = TLON_G(:,:) + pi2

end subroutine calc_tpoints_global

end module pop_interface


      SUBROUTINE STDPND(KTEST)
C
C        'STDPND' STORES INITIAL CONDITIONS FOR STACKING CASES
C
C         WRITTEN BY E.A.LAWLOR OF AVCO SYSTEM DIVISION
C         MODIFIED BY K. YONG OF COMPUTER SCIENCES CORP.
C
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER*4 ACNTRL
C
C
      COMMON/CONSTS/ PI,TWOPI,RADIAN
C
      COMMON/IMAIN1/ IDATE,LSAVE,INOPT,IPLOT,NUMEQS,IPLTPE,IORB,ITAPE
C
      COMMON/IPOOL1/ IGRAV,IDAMP,IK,K1,ITIM,IAB,IAPS,IBB,IBPS,NK(10),
     .               LK(10),LLK(10)
C
      COMMON/MOMENT/ ACNTRL,IVISCS,IATTDE,IMGMTS,IWHEEL,NPULSE
C
      COMMON/RATTDE/ DTMXA,PXI,PXO,EIT,REFTIM,TMX1,TMX2,CMX,ISW
C
      COMMON/RMAIN1/ DELTAT,FACTOR,FREQ,TSTOP,DELMIT,
     .               UPBND(150),DNBND(150)
C
      COMMON/RPOOL1/ RHOK(10),TIME,SA(3,3),FM1(3,3),ZLK(10),OMEG(3),
     .               ZLKP(10),ZLKDP(10),CMAT(3,3),GBAR(3,3),YBCM(3),
     .               ZBZK(3,10),FCM(3,3),DTO,PHID,PHI
C
      COMMON/XIN1/ PSI1,THET1,PHI1,ETTA,ZETTA,ITEST1
C
      COMMON/XIN2  / ALFAE,BETAE,GAMAE,OMBC(3),ITEST2
C
C
      COMMON/GRNTST/ALFAEG,DELTAG,PHASEG,ALTUDE,OMGY(3),
     *       GACC(3),GLOCAT(3),IGRUND,IALTUD
C
      DIMENSION SOMBC(3),SOMEG(3)
      DIMENSION SOMGY(3)
C
C
      IF (KTEST.EQ.2) GO TO 40
C
      IF(NPULSE.LT.0) NPULSE=0
      DSAVE=DELTAT
      FASAVE=FACTOR
      FRSAVE=FREQ
      DESAVE=DELMIT
C
C
      SALFAE=ALFAE
      SBETAE=BETAE
      SGAMAE=GAMAE
      SPSI1=PSI1
      STHET1=THET1
      SPHI1=PHI1
      SALFAG=ALFAEG
      SDELTG=DELTAG
      SPHASG=PHASEG
C
      DO 20 I=1,3
      SOMEG(I)=OMEG(I)
      SOMGY(I)=OMGY(I)
   20 SOMBC(I)=OMBC(I)
C
C
C
      RETURN
C
C
   40 DELTAT=DSAVE
      FACTOR=FASAVE
      FREQ=FRSAVE
      DELMIT=DESAVE
      TMX1=0.D0
      TMX2=0.D0
      NPULSE=-4
C
C
C
      ALFAE=SALFAE
      BETAE=SBETAE
      GAMAE=SGAMAE
      PSI1=SPSI1
      THET1=STHET1
      PHI1=SPHI1
      ALFAEG=SALFAG
      DELTAG=SDELTG
      PHASEG=SPHASG
C
C
      DO 70 I=1,3
      OMBC(I)=SOMBC(I)
      OMGY(I)=SOMGY(I)
   70 OMEG(I)=SOMEG(I)/RADIAN
C
      RETURN
      END


      SUBROUTINE HOGRAP( NOUT, SAMPLE, PI,
     &                   STRMAX, STRNOP, STRNON, STRCEN, STRRAD,
     &                   STRLVC, STRLBO, STRSBO, STRBRD,
     &                   ATMAX, ATNO, ATBRK, ATRES,
     &                   ATCHN, ATRNO, ATXYZ, ATVDW, ATBND,
     &                   LSPHBX, SHORTO, POSNO, CVECT, CUTSIZE,
     &			 CONNR, LEXTRA)
      IMPLICIT NONE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 1994 Oliver Smart & Birkbeck College, All rights reserved    *
C * (c) 1996 Oliver Smart & Birkbeck College, All rights reserved    *
C * (c) 1997 Oliver Smart                    *
C *                                                                  *
C ********************************************************************
C
C Modification history:
C
C Date	Author		Modification
C 07/94 O.S. Smart      First version
C 11/95 O.S.S.		conductance calc and SHORTO implemented
C 09/96 O.S.S.		Format of output radically changed
C			conductance calc removed (use CAPSULE only)
C 11/96 O.S.S. 		Call to s/r hsurfp added - produces additional
C			information like proportion of surface which
C			is closest to O at any particular Z.
C 11/96 O.S.S.          Call to helefi to work out electostatic potential
C 12/97 O.S.S.		cut off lists introduced to speed calculations
C			change here is vble cutsize
C 01/00 O.S.S.		Connolly information output and LEXTRA keyword introduce
C
C This s/r contains code to output data to allow user to plot
C graphs of HOLE's result.  Upto 07/94 included in the main
C program but split of on introducing sphere-box option.

C passed variables *************

C output stream no. (usually set to 6) RETURN UNCHANGED
      INTEGER			NOUT

C The sampling distance between planes used in hole,
C needed to work out a running volume
C (n.b. normally supplied -ve)
      DOUBLE PRECISION		SAMPLE

C will need PI (worked out in HOLE)
      DOUBLE PRECISION		PI

C store for sphere centres and radii
C store the initial point as no 0 and subseqently points in the +ve
C bit. Points below the initial point are stored in -ve bit.
C maximum number of entries
      INTEGER                   STRMAX
C the no. of entries, +Ve entries -Ve entries
      INTEGER                   STRNOP, STRNON
C the centres and radii
      DOUBLE PRECISION          STRCEN(3,-STRMAX:STRMAX),
     &                          STRRAD(-STRMAX:STRMAX)
C 08/07/94
C vbles to store the dimensions found in the spherebox
C options.
      DOUBLE PRECISION          STRLVC(3,-STRMAX:STRMAX),
     &                          STRLBO(-STRMAX:STRMAX),
     &                          STRSBO(-STRMAX:STRMAX),
     &                          STRBRD(-STRMAX:STRMAX)

C maximum number and actual number of atoms read in from each file:
      INTEGER                   ATMAX, ATNO

C atom names found in Brookhaven file:
      CHARACTER*4               ATBRK(ATMAX)

C residue name in brook
      CHARACTER*3               ATRES(ATMAX)

C chain identifier in brookhaven pdb file
      CHARACTER*1               ATCHN(ATMAX)

C integer residue no.
      INTEGER                   ATRNO(ATMAX)

C co-ordinates
      DOUBLE PRECISION          ATXYZ( 3, ATMAX)

C vdw and bond radii of each atoms
      DOUBLE PRECISION          ATVDW(ATMAX), ATBND(ATMAX)

C pdb format output file 'atoms' are sphere centres
C default to none by setting FPDBSP to 'NONE'
C (commented out - now done in main program)
C      CHARACTER*200		FPDBSP
C      INTEGER			SPDBSP

C logical flag if .true. then spherebox option is turned on
      LOGICAL			LSPHBX

C 11/95 introduce new variable to reduce text output -
C if oshort =
C 0: full text output
C 1: no in run progress reported
C 2: ditto plus no graph type output - only leaving
C    Minimum radius & conductance calculations.
C 3: All text output other than input card mirroring
C    and error messages turned off
      INTEGER                   SHORTO

C position number for write
      INTEGER			POSNO

C channel direction unit vector
      DOUBLE PRECISION		CVECT(3)

C cut off list control vble, -ve: no cutoff lists used in calculation
C otherwise this is the additional radius above the sphere radius
C to be used for cutoff list (see s/r holeen) needed here for calls to
C holeen
      DOUBLE PRECISION		CUTSIZE

C option CONN introduced 1/00 -
C CONNR(1) is the connolly surface probe radius (default 1.15Angs)
C          the option is turned off by setting this radius negative
C CONNR(2) is the grid size to be used in the calculation - default .25 angs
C effective pore radius is store in STRBRD
      DOUBLE PRECISION		CONNR(2)

C extra key controls whether information as for
C Graph of surface properties vs coordinate along cvect
C and crude electrostatic potential
C produced by calls to HSURFP and HELEFI from HOGRAP
      LOGICAL			LEXTRA

C internal vbles ***************

C loop count for going through stored records, one for xyz
      INTEGER			SCOUNT, XCOUNT

C 05/94 add inverse area integration for Mark Sansom -
C just work out running total of sample/(pi*strrad^2)
C 01/00 rename to resistance for that is waht it is - and add conn versions
      DOUBLE PRECISION          TORESI, CTORES

C working real numbers (used to work out distance along channel)
      DOUBLE PRECISION		CDIST, TOCDIS

C the minimum radius found
      DOUBLE PRECISION          MINRAD, CMINR

C need some dummy variables for s/r HOLEEN call
      INTEGER			IAT1, IAT2, IAT3
      DOUBLE PRECISION		DAT2, DAT3
C also a test position and energy
      DOUBLE PRECISION		TSTCEN(3), TSTENG

C string to write numbers to two significant figures,
C the last character of this
      CHARACTER*8		ST2SF
      INTEGER			LST2SF

C coordinate along cvect
      DOUBLE PRECISION		CVCOOR

C average potential - not needed here but has to be included
C in call to HELEFI
      DOUBLE PRECISION		AVGPOT

C macroscopic conductance - and that for connolly
      DOUBLE PRECISION		GMACRO, CGMACR

C if doing connolly - work out average requiv/rspherical
C need this to correct for slabs that have escaped
      DOUBLE PRECISION		CRATIO
      INTEGER			CRATNO

C estimated radius for escaped Connolly sections
      DOUBLE PRECISION		RESTIM

C end of decs ******************

        IF (SHORTO.LT.2) WRITE( NOUT, '(A)')
     &' ',
     &' N.b. Graph information routine (HOGRAP) differs ',
     &'        markedly from previous versions!',
     &'       Information now is written from -ve end',
     &'       to +ve in one pass'

        IF (SHORTO.LT.2) WRITE( NOUT, '(A)')
     &' ',
     &' Explanation of the meaning of each column: ',
     &' First column "cenxyz.cvec" is the coordinate in the',
     &'   direction of the channel vector i.e. if the channel',
     &'   vector is in z (0 0 1) then it is the z coordinate.',
     &' The second column "radius" is the hole pore radius ',
     &'   (as defined in the Biophys J 1993) article).',
     &' The third column "cen_line_D" is the distance ',
     &'   measured along the pore centre line - with the ',
     &'   first point found set to zero. This was the first',
     &'   thing that I used to measure the distance along a pore',
     &'   but "cenxyz.cvec" is a much better general measure. ',
     &'   However, by comparing changes in this distance to changes in ',
     &'   "cenxyz.cvec" one can get a measure of how straight a ',
     &'   channel is.',
     &' The fourth column "sum{s/(area)}" is useful in conductance',
     &'   prediction -',
     &'   basically it is the sum of the thickness of each slab',
     &'   divided by its area. HOLE uses this measure to estimate',
     &'   the macroscopic conductance of a channel.',
     &' If any of this worries you one can see the "raw" results',
     &'   of a standard hole run by producing a sphpdb file and ',
     &'    directly looking at the results.'

C initialize minimum radius
      MINRAD = 99999.
      CMINR  = 99999.
      TORESI = 0.0
      CTORES = 0.0

C n.b. sample must be +ve
      SAMPLE = ABS(SAMPLE)

C if doing connolly - work out average requiv/rspherical
C need this to correct for slabs that have escaped
      IF (CONNR(1).GT.0.) THEN
        CRATIO = 0.
        CRATNO = 0
C go thru all records
        DO 1701 SCOUNT = -STRNON, STRNOP
C if the record has a connolly requiv
          IF (STRBRD(SCOUNT).LT.1E06) THEN
	    CRATIO = CRATIO + STRBRD(SCOUNT)/STRRAD(SCOUNT)
	    CRATNO = CRATNO + 1
	  ENDIF
1701    CONTINUE
        CRATIO = CRATIO/REAL(CRATNO)
        IF (SHORTO.LT.2)  WRITE( NOUT,'(A,F10.3)')
     & ' Ratio of Connolly Requiv to HOLE spherical probe=', CRATIO

      ENDIF

C write column headers
      IF (CONNR(1).LT.0.) THEN
        IF (SHORTO.LT.2)  WRITE( NOUT,'(5A12)')
     &' cenxyz.cvect',
     &' radius',
     &' cen_line_D',
     &' sum{s/(area)}',
     &' point source'
      ELSE
        IF (SHORTO.LT.2)  WRITE( NOUT,'(8A12)')
     &' cenxyz.cvect',
     &' radius',
     &' cen.line.dis',
     &' integ.s/(area)',
     &' Requiv',
     &' Requiv_estim',
     &' Conn_s/Area',
     &' point source'
      ENDIF

C 18/01/00
C routine is becoming too complex - write out records from
C -strnon to strnop in one shot - previously did
C 0 to -strnon and 0 to strnop seperately
C this allowed the cen.line.dis to go from zero
C instead workout offset at the outset!
      TOCDIS = 0.
      DO 1702 SCOUNT = -STRNON+1, 0
C distance to previous point
	CDIST = (STRCEN(1,SCOUNT-1)-STRCEN(1,SCOUNT))**2 +
     &	        (STRCEN(2,SCOUNT-1)-STRCEN(2,SCOUNT))**2 +
     &	        (STRCEN(3,SCOUNT-1)-STRCEN(3,SCOUNT))**2
        CDIST = SQRT(CDIST)
C start TOCDIS -ve such that point zero is regarded as zero
	TOCDIS = TOCDIS - CDIST
1702  CONTINUE

C go thru all points -ve to +ve
      DO 77 SCOUNT= -STRNON, STRNOP
        IF (SCOUNT.EQ.-STRNON) THEN
C if we are at the end cannot look at previous point - there isn't any!
	  CDIST = 0.0
	ELSE
C the distance from point to the previous one
	  CDIST = (STRCEN(1,SCOUNT-1)-STRCEN(1,SCOUNT))**2 +
     &	          (STRCEN(2,SCOUNT-1)-STRCEN(2,SCOUNT))**2 +
     &	          (STRCEN(3,SCOUNT-1)-STRCEN(3,SCOUNT))**2
          CDIST = SQRT(CDIST)
C new feature April 1993
C check the sphere radius of the mid-points
C load the mid-point into newcen
          TSTCEN(1) = 0.5*(STRCEN(1,SCOUNT-1)+STRCEN(1,SCOUNT))
          TSTCEN(2) = 0.5*(STRCEN(2,SCOUNT-1)+STRCEN(2,SCOUNT))
          TSTCEN(3) = 0.5*(STRCEN(3,SCOUNT-1)+STRCEN(3,SCOUNT))
C coordinate of new point
          CALL DDOT( TSTCEN, CVECT, CVCOOR)
C find energy of point newcen
C - energy is minus radius the largest sphere
C which can be centered at this point without vdW overlap
          CALL HOLEEN( TSTCEN, TSTENG, IAT1, IAT2, IAT3, DAT2, DAT3,
     &                 ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)
C keep a count of the integrated res
          TORESI = TORESI + 0.5*SAMPLE/(PI*(TSTENG)**2)
C the mid-point will be at distance dum2 + dum/2
C 19/07/94 do not want this info if doing sphere-box
          IF (.NOT.LSPHBX) THEN
            IF (CONNR(1).LT.0.) THEN
              IF (SHORTO.LT.2) WRITE( NOUT,'(4F12.5,A12)')
     &                 CVCOOR, -TSTENG,
     &                 (TOCDIS+0.5*CDIST), TORESI, ' (mid-point)'
            ELSE
              IF (SHORTO.LT.2) WRITE( NOUT,'(4F12.5,36X,A12)')
     &                 CVCOOR, -TSTENG,
     &                 (TOCDIS+0.5*CDIST), TORESI, ' (mid-point)'
            ENDIF
          ENDIF
C smallest sphere?
          IF  (-TSTENG.LT.MINRAD) MINRAD = -TSTENG
C add the distance between sphere centre scount and previous centre
	  TOCDIS = TOCDIS + CDIST
        ENDIF

C running resistance - uniform probe uses 1/2 points
        TORESI = TORESI + 0.5*SAMPLE/(PI*(STRRAD(SCOUNT))**2)
C for connolly 1/2 points ignored
C if the radius is set at 1e-06 then have escaped so use approximate requiv
        IF (CONNR(1).GT.0.) THEN
          IF (STRBRD(SCOUNT).GT.0.999E6) THEN
	    RESTIM = CRATIO*STRRAD(SCOUNT)
	  ELSE
	    RESTIM = STRBRD(SCOUNT)
	  ENDIF
          CTORES = CTORES + SAMPLE/(PI*RESTIM*RESTIM)
	ENDIF

C coordinate
        CALL DDOT( STRCEN(1,SCOUNT), CVECT, CVCOOR)

C write out distance along pore centre, radius found
C and x, y, z of pore centre
C (Oct '93 some people prefer to plot graphs against x coord etc.)
        IF (CONNR(1).LT.0.) THEN
	  IF (SHORTO.LT.2) WRITE( NOUT,'(4F12.5,A12)')
     &                 CVCOOR, STRRAD(SCOUNT),
     &                 TOCDIS, TORESI, ' (sampled)'
        ELSE
C connolly version - add connolly equivalent radius and the integrated resistance
C term
	  IF (SHORTO.LT.2) WRITE( NOUT,'(4F12.5,3F12.3,A12)')
     & CVCOOR, STRRAD(SCOUNT), TOCDIS, TORESI,
     &         STRBRD(SCOUNT), RESTIM, CTORES, ' (sampled)'
        ENDIF
        IF  (STRRAD(SCOUNT).LT.MINRAD) MINRAD = STRRAD(SCOUNT)
        IF  (STRBRD(SCOUNT).LT.CMINR)  CMINR  = STRBRD(SCOUNT)

77    CONTINUE

C write out minimum radius if shorto < 3 (3 means no output)
      IF (SHORTO.LT.3) WRITE( NOUT, '(/A,F10.3,A/)' )
     &' Minimum radius found: ', MINRAD, ' angstroms.'
      IF ((SHORTO.LT.3).AND.CONNR(1).GT.0)
     &                 WRITE( NOUT, '(A,F10.3,A/)' )
     &' Minimum equivR found: ', CMINR, ' angstroms.'

C Area meaningless if radius goes -ve
      IF (MINRAD.LT.0.) TORESI = 1D8

C write out predicted conductivity
      IF (SHORTO.LT.3) WRITE( NOUT, '(//A/A,F8.3,A)')
     &' For spherical probe approach, The geometric factor',
     &'         F= sum(ds/area) along channel is ', TORESI,
     &                                          ' angstroms**-1'
C write out predicted conductances to two signicant figures
      CALL SF2( ST2SF, LST2SF, 100D0/TORESI)
      IF (SHORTO.LT.3) WRITE( NOUT, '(A)')
     &' This yields a macroscopic predicted molar conductance of:',
     &'   (1/rho)*(100/F)= ('//ST2SF(1:LST2SF)//'/rho) pS,',
     &'   where rho is the conductivity of 1M permeant ion in ohm m.',
     &' N.B. this is a macroscopic conductance - an overestimate ',
     &' Empirically corrected conductances currently only available',
     &' With the CAPSULE option (although its not that stable!)'

      GMACRO = 1200D0/TORESI
      CALL SF2( ST2SF, LST2SF, GMACRO)
      IF (SHORTO.LT.3) WRITE( NOUT, '(A,A,A)')
     &' For 1M KCl rho= 1/12 (ohm m), So Gmacro= ',
     &                  ST2SF(1:LST2SF), ' pS/M.'
C do same for connolly numbers
      IF (CONNR(1).GT.0.) THEN
        IF (SHORTO.LT.3) WRITE( NOUT, '(//A/A,F8.3,A)')
     &' For Connolly-based approach, The geometric factor',
     &'         F= sum(ds/area) along channel is ', CTORES,
     &                                          ' angstroms**-1'
C write out predicted conductances to two signicant figures
        CALL SF2( ST2SF, LST2SF, 100D0/CTORES)
        IF (SHORTO.LT.3) WRITE( NOUT, '(A)')
     &' This yields a macroscopic predicted molar conductance of:',
     &'   (1/rho)*(100/F)= ('//ST2SF(1:LST2SF)//'/rho) pS,',
     &'   where rho is the conductivity of 2M permeant ion in ohm m.',
     &' N.B. this is a macroscopic conductance - an overestimate ',
     &' Empirically corrected conductances currently only available',
     &' With the CAPSULE option (although its not that stable!)'

        CGMACR = 1200D0/CTORES
        CALL SF2( ST2SF, LST2SF, CGMACR)
        IF (SHORTO.LT.3) WRITE( NOUT, '(A,A,A)')
     &' For 1M KCl rho= 1/12 (ohm m), So Conn_Gmacro= ',
     &                  ST2SF(1:LST2SF), ' pS/M.'
      ELSE
C blank out detailed numbers
        CGMACR = -1.
      ENDIF
C need to write out detailed numbers
      IF (SHORTO.LT.3) WRITE( NOUT, '(A,I6,3(A,F12.5),A)')
     &'  (TAG ', POSNO,
     &  '   Rmin=', MINRAD,
     &  '   Gmacro=', GMACRO, ' Conn_Gmacro=', CGMACR, ' ).'

C sphere box option - first bodge is just to write data at the
C points worked out (leave code above)
      IF (LSPHBX) THEN
        IF (SHORTO.LT.2) WRITE( NOUT, '(A)')
     &' ',
     &' Additional sphere-box data: ',
     &' x, y & z of centre, longbox, shortbox, boxrad'
        DO 40 SCOUNT= -STRNON, STRNOP
          IF (SHORTO.LT.2) WRITE( NOUT,'(6F12.5,A)')
     &      (STRCEN(XCOUNT,SCOUNT), XCOUNT=1, 3),
     &      STRLBO(SCOUNT), STRSBO(SCOUNT), STRBRD(SCOUNT)
40      CONTINUE
      ENDIF

C additional info from hsurfp?
      IF (LEXTRA) THEN
        CALL HSURFP( NOUT, CVECT,
     &             STRMAX, STRNOP, STRNON, STRCEN, STRRAD,
     &             SHORTO, SAMPLE, PI,
     &             ATMAX, ATNO, ATBRK, ATRES,
     &             ATCHN, ATRNO, ATXYZ, ATVDW, ATBND, CUTSIZE)

C 11 Nov 96 - work out the electrostatic potential created along
C pore centre line by formal charges in the system
C s/r should work both with the capsule and normal call -
C hence double ref to STRCEN (capsule has two centres).
        CALL HELEFI( NOUT, AVGPOT, CVECT, SHORTO,
     &             STRMAX, STRNOP, STRNON, STRCEN, STRCEN,
     &             ATMAX, ATNO, ATBRK, ATRES,
     &             ATCHN, ATRNO, ATXYZ, ATVDW, ATBND)
      ENDIF
C return here
      RETURN
      END


subroutine deter_subdomain(mype)

!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    deter_subdomain          perform domain decomposition
!   prgmmr: da silva       org: np20                date: 2006-06-28
!
! abstract: The nxPE and nyPE defines the layout, that is, nxPE is the number of
!           processors used to decompose the longitudinal dimensional, while nyPE
!           the number of processors used to decompose the latitudinal dimension.
!           By construction, nPE = nxPE * nyPE. If a layout is not specified in
!           the namelist, it defaults to nxPE=nyPE=-1 and we revert back to
!           NCEP's original decomposition.
!
! program history log:
!   2006-06-28  da Silva - added option to perform an ESMF-like
!                          domain decomposition based on a layout.
!                          If no layout is defined in mpimod then
!                          it reverts back to NCEP's original algorithm.
!   2013-11-11  Todling  - adapt from GSI
!
!   input argument list:
!     mype      - mpi task number
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$

  use comm_mod, only: nxPE, nyPE
  implicit none
  integer,intent(in):: mype

! If a layout is provided, use it for the domain decomposition
! ------------------------------------------------------------
  if ( nxPE > 0 .AND. nyPE > 0 ) then

       call deter_subdomain_withLayout ( myPE, nxPE, nyPE ) ! ESMF-like

! Otherwise, use NCEP original algorithm
! --------------------------------------
  else

       call deter_subdomain_noLayout ( mype ) ! NCEP's original algorithm

  endif

end subroutine deter_subdomain

subroutine deter_subdomain_noLayout(mype)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    deter_subdomain_noLayout   perform domain decomposition
!   prgmmr: weiyu yang       org: np20                date: 1998-05-14
!
! abstract: Given an array of the observation computation load and
!           the number of available mpi tasks (npe), this routine
!           decomposes the total analysis grid into npe subdomains
!
! program history log:
!   1998-05-14  weiyu yang
!   1999-08-24  derber, j., treadon, r., yang, w., first frozen mpp version
!   2004-06-01  treadon - simplify algorithm
!   2004-07-28  treadon - add only to module use, add intent in/out
!   2005-10-17  derber - rewrite routine using simpler algorithm
!   2005-10-26  treadon - correct error in 100 format text
!   2008-06-04  safford - rm unused vars
!   2008-09-05  lueken - merged ed's changes into q1fy09 code
!
!   input argument list:
!     mype      - mpi task number
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use type_kinds, only: fp_kind,ip_kind
! use gridmod, only: periodic,periodic_s
  use variables, only: lon1,lat1,nlon,nlat,&
       ilat1,istart,jlon1,jstart,npe
  implicit none

! Declare passed variables
  integer(ip_kind),intent(in):: mype

! Declare local variables
  integer(ip_kind) npts,nrnc,iinum,iileft,jrows,jleft,k,i,jjnum
  integer(ip_kind) j,mm1,iicnt,ipts,jjleft
  integer(ip_kind),dimension(npe+1):: iiend,jjend,iistart
  real(fp_kind):: anperpe

!************************************************************************
! Compute number of points on full grid and target number of
! point per mpi task (pe)
  npts=nlat*nlon
  anperpe=float(npts)/float(npe)

! Start with square subdomains
  nrnc=sqrt(anperpe)
  iinum=nlon/nrnc
  if(iinum==0) iinum=1
  iicnt=nlon/iinum
  iileft=nlon-iicnt*iinum
  jrows=npe/iinum
  jleft=npe-jrows*iinum

! Adjust subdomain boundaries
  k=0
  istart=1
  jstart=1
  iistart(1)=1
  do i=1,iinum
     ipts = iicnt
     if(i <= iileft)ipts=ipts+1
     iiend(i)=iistart(i)+ipts-1
     iistart(i+1)=iiend(i)+1
     jjnum=jrows
     if(i <= jleft)jjnum=jrows+1

     do j=1,jjnum
        k=k+1
        jlon1(k)=ipts
        jstart(k)= iistart(i)
        ilat1(k)=nlat/jjnum
        jjleft=nlat-ilat1(k)*jjnum
        if(j <= jjleft)ilat1(k)=ilat1(k)+1
        if(j > 1)istart(k)=jjend(j-1)+1
        jjend(j)=istart(k)+ilat1(k)-1

!       if (jlon1(k)==nlon) then
!          periodic=.true.
!          periodic_s(k)=.true.
!       endif
        if(mype == 0) &
             write(6,100) k-1,istart(k),jstart(k),ilat1(k),jlon1(k)
     end do
  end do
100 format('DETER_SUBDOMAIN:  task,istart,jstart,ilat1,jlon1=',6(i6,1x))

! Set number of latitude and longitude for given subdomain
  mm1=mype+1
  lat1=ilat1(mm1)
  lon1=jlon1(mm1)

  return

end subroutine deter_subdomain_noLayout

!-------------------------------------------------------------------------
!BOP

  subroutine deter_subdomain_withLayout(mype,nxpe,nype)

! !USES:

  use type_kinds, only: ip_kind
! use gridmod, only: periodic,periodic_s
  use variables, only: lon1,lat1,nlon,nlat,&
       ilat1,istart,jlon1,jstart

  implicit none

! !INPUT PARAMETERS:

  integer(ip_kind),intent(in) :: mype,nxpe,nype

! !OUTPUT PARAMETERS:

  ! all the variables in "use gridmod" are defined here

! !DESCRIPTION: determine GSI subdomains using a layout
!
! !REVISION HISTORY:
!
!   2006-06-27  cruz
!
! !REMARKS:
!   language: f90
!   machine:  ibm rs/6000 sp; sgi origin 2000; compaq/hp
!
! !AUTHOR:
!    cruz           org: gmao                date: 2006-06-27
!
!EOP
!-------------------------------------------------------------------------

! Declare local variables

  integer(ip_kind) i,j,k,iinum,jjnum,iistart,jjstart
  integer(ip_kind) lsetx,lsety,nxseg,nyseg
  integer(ip_kind),allocatable,dimension(:) :: imxy, jmxy
  integer(ip_kind) im,jm,npe,mm1,ierr

! start

  im=nlon; jm=nlat
  npe=nxpe*nype
  allocate(imxy(0:nxpe-1),jmxy(0:nype-1), stat=ierr)
  if(ierr /= 0) then
    write(6,*)' DETER_SUBDOMAIN: ALLOCATE ERROR.'
    call mpi_finalize(ierr)
  end if

  call GET_LOCAL_DIMS ( im,imxy,nxpe )
  call GET_LOCAL_DIMS ( jm,jmxy,nype )

! compute subdomain boundaries  (axis indices)

  k=0
  iinum=imxy(0)
  jjnum=jmxy(0)
  nxseg=2
  nyseg=2
  istart=1
  jstart=1
  iistart=1
  jjstart=1
  lsetx=npe/nype
  lsety=npe/nype
  do j=0,nype-1
     do i=0,nxpe-1
       k=k+1
       if(i>0) then
         if(imxy(i)<imxy(i-1)) iinum = imxy(i)
       end if
       if(j>0) then
         if(jmxy(j)<jmxy(j-1)) jjnum = jmxy(j)
       end if
       ilat1(k)=jjnum
       jlon1(k)=iinum
       if(k>1) then
         if(nxseg<=lsetx) then
           jstart(k)=iistart+jlon1(k)
           iistart=jstart(k)
           nxseg=nxseg+1
         else
           jstart(k)=1
           iistart=1
           nxseg=2
         end if
         if(nyseg<=lsety) then
           istart(k)=jjstart
           nyseg=nyseg+1
         else
           if(ilat1(k)<ilat1(k-1)) then
             istart(k)=jjstart+ilat1(k)+1
           else
             istart(k)=jjstart+ilat1(k)
           end if
           jjstart=istart(k)
           nyseg=2
         end if
       end if
       if(mype == 0) &
            write(6,100) k,istart(k),jstart(k),ilat1(k),jlon1(k)
     end do
  end do

100 format('DETER_SUBDOMAIN(ESMF-like):  task,istart,jstart,ilat1,jlon1=',5(i6,1x))

! Set number of latitude and longitude for given subdomain
  mm1=mype+1
  lat1=ilat1(mm1)
  lon1=jlon1(mm1)

  deallocate(imxy,jmxy, stat=ierr)
  if(ierr /= 0) then
    write(6,*)' DETER_SUBDOMAIN: DEALLOCATE ERROR.'
    call mpi_finalize(ierr)
  end if

  return

  CONTAINS

  subroutine GET_LOCAL_DIMS ( dim_world,dim,NDEs )
  implicit   none
  integer    dim_world, NDEs
  integer    dim(0:NDEs-1)
  integer    n,im,rm
  im = dim_world/NDEs
  rm = dim_world-NDEs*im
  do n=0,NDEs-1
                    dim(n) = im
    if( n.le.rm-1 ) dim(n) = im+1
  enddo
  end subroutine GET_LOCAL_DIMS

  end subroutine deter_subdomain_withLayout


function realfileversion(versionstring, lenstring)
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: realfileversion.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/io/src/output/realfileversion.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Converts a version number string (format mm.nn.xx.yy)
!              in a real number (format mm.nnxxyy) to allow comparison
!              with other version numbers
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
   use precision
   implicit none
!
! Global parameters
!
   integer      :: lenstring
   real(fp)     :: realfileversion
   character(*) :: versionstring
!
! Local parameters
!
   integer       :: p1             ! Index of first point in string (mm.nn.xx.yy)
   integer       :: p2             ! Index of second point in string (mm.nn.xx.yy)
   integer       :: p3             ! Index of third point in string (mm.nn.xx.yy)
   character(16) :: versionstring1 ! Help string to to remove the third point
!
!! executable statements -------------------------------------------------------
!
   p1 = index(versionstring(      1:lenstring), '.')
   p2 = index(versionstring(   p1+1:lenstring), '.')
   p3 = index(versionstring(p1+p2+1:lenstring), '.')

   versionstring1 = ' '
   if (p3 > 0) then
      versionstring1 = versionstring(1:p1+p2-1)//versionstring(p1+p2+1:p3-1)//versionstring(p1+p2+p3+1:lenstring)
   else
      versionstring1 = versionstring(1:p1+p2-1)//versionstring(p1+p2+1:lenstring)
   endif
   read(versionstring1, *) realfileversion
end function realfileversion