! Stefan Petri
!
!
!
!
!-----------------------------------------------------------------------
!
! Fortran-to-python wrapper for the atmospheric model Aeolus2
!
!
! Fortran-to-python wrapper for the atmospheric model Aeolus2
! Since it was not feasible to get the python interpreter running
! compiled and linked into the FMS/Fortran executable, we now
! start it as separate executable via MPI_Comm_spawn,
! and communicate with that via quasi-remote-procedure calls,
! i.e. all Fortran variables/arrays are packed into MPI
! messages and sent to the Python side, where they are unpacked into
! Python variables resp. numpy arrays. And vice vers. Sigh.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! !!
!! GNU General Public License !!
!! !!
!! This file is part of the Flexible Modeling System (FMS). !!
!! !!
!! FMS is free software; you can redistribute it and/or modify !!
!! it and are expected to follow the terms of the GNU General Public !!
!! License as published by the Free Software Foundation. !!
!! !!
!! FMS 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 FMS; if not, write to: !!
!! Free Software Foundation, Inc. !!
!! 59 Temple Place, Suite 330 !!
!! Boston, MA 02111-1307 USA !!
!! or see: !!
!! http://www.gnu.org/licenses/gpl.txt !!
!! !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#include
module aeolus2fms_mod
#ifndef use_libMPI
Error: Cannot compile with -DMPMD_ATMOS but without -Duse_libMPI
#endif
use mpi ! , only: ....
use ifport, only: getpid
use tracer_manager_mod, only: NO_TRACER
implicit none
private
public aeolus2fms_interface_check
public aeolus2fms_init_grid, aeolus2fms_get_axes_coords, aeolus2fms_init
public aeolus2fms_atmosphere_down, aeolus2fms_atmosphere_up
public aeolus2fms_finish, aeolus2fms_restart
!public aeolus2fms_get_boundary
public aeolus2fms_get_bottom_mass, aeolus2fms_get_bottom_wind, aeolus2fms_get_stock_pe
#ifdef MPMD_ATMOS
public setup_mpmd_comm
#endif
!include "mpif.h"
integer :: nlons_global, nlats_global
logical :: lon_0_360
! Communicator between FMS atm tasks, created by FMS mpp.
integer :: atmos_comm
! Communicator for all FMS tasks.
! Spawn case: MPI_COMM_WORLD; MPMD case: created by setup_mpmd_comm()
integer :: fms_comm = MPI_COMM_WORLD
! Communicator between FMS atm tasks and python peer tasks.
! Spawn case: created by Spawn; MPMD case: MPI_COMM_WORLD
integer :: inter_comm
#ifdef MPMD_ATMOS
integer :: world_npes, mpmd_fms_npes = 0, mpmd_other_npes = 0
#endif
integer :: pe, root_pe, atm_npes
! Spawn case: same as pe; MPMD case: mpmd_fms_pes+pe
integer :: peer_pe
integer :: is, ie, js, je ! local domain boundary indices
integer :: nr_tracers = 0 ! total number of tracers in surf_diff_type fields
integer :: q_ind = NO_TRACER ! index of humidity in tracers array
integer :: co2_ind = NO_TRACER ! index of CO2 in tracers array
contains
#ifdef MPMD_ATMOS
subroutine setup_mpmd_comm(fms_comm_out)
integer, intent(out) :: fms_comm_out
character(len=8) :: envvar
integer :: len
integer :: group_world, group_fms
integer :: ranks(3,1)
integer :: ierror
write(*,*) 'setup_mpmd_comm calling MPI_Init()'
call flush(6)
call MPI_Init(ierror)
fms_comm_out = MPI_COMM_WORLD
call MPI_Comm_rank(MPI_COMM_WORLD, pe, ierror)
call MPI_Comm_size(MPI_COMM_WORLD, world_npes, ierror)
call get_environment_variable('MPMD_FMS', envvar, len)
write(*,*) 'MPMD_FMS ',envvar
if (len > 0) read(envvar,*) mpmd_fms_npes
write(*,*) ' as int ',mpmd_fms_npes
call get_environment_variable('MPMD_OTHER', envvar, len)
write(*,*) 'MPMD_OTHER ',envvar
if (len > 0) read(envvar,*) mpmd_other_npes
write(*,*) ' as int ',mpmd_other_npes
if (mpmd_other_npes > 0) then
! all FMS/Fortran tasks belong to comm_fms
if (pe >= mpmd_fms_npes) then
write(*,*) 'Fatal: my pe >= MPMD_FMS', pe, mpmd_fms_npes
call flush(6)
stop
end if
if (world_npes /= mpmd_fms_npes + mpmd_other_npes) then
write(*,*) 'Fatal: world_npes /= mpmd_fms_npes + mpmd_other_npes', &
world_npes, mpmd_fms_npes, mpmd_other_npes
call flush(6)
stop
end if
call MPI_Comm_group(MPI_COMM_WORLD, group_world, ierror)
ranks(1,1) = 0; ranks(2,1) = mpmd_fms_npes-1; ranks(3,1) = 1;
call MPI_Group_range_incl(group_world, 1, ranks, group_fms, ierror)
write(*,*) 'MPI_Group_range_incl got ierror',ierror
call MPI_Comm_create(MPI_COMM_WORLD, group_fms, fms_comm, ierror)
write(*,*) 'MPI_Comm_create got ierror',ierror
end if
fms_comm_out = fms_comm
return
end subroutine setup_mpmd_comm
#endif
subroutine aeolus2fms_interface_check(atmos_comm_in)
integer, intent(in) :: atmos_comm_in
character(len=MPI_MAX_LIBRARY_VERSION_STRING) :: mpi_version_string
! some magical values for testing the interface between Fortran90 and python code.
! we pass them from Fortran90 to python functions and test in there if they were
! received correctly.
integer, parameter :: deadbeef = X'eadbeef' ! X'deadbeef' yields overflow error on 32bit machines
integer, parameter :: fse = 4711
real, parameter :: onetwothree = 1234567809.0987654321D0, &
pitest = 3.1415926535897932384626433832795029D0 ! from linux
logical :: true = .true., false = .false., flag
integer :: kind_i = KIND(deadbeef), kind_r = KIND(pitest), kind_l = KIND(true)
real, dimension(2,3) :: testarray2d
real, dimension(2,3) :: response2d ! to store the data that was sent back from the python side
!real, dimension(2,3,4) :: testarray3d
integer :: i, j, k, ierror
integer :: inter_comm_size, universe_size = -1, remote_size = -1
integer :: mypid
character(len=25) :: command, argv(5)
integer, dimension(:), allocatable :: remotepids
integer :: status(MPI_STATUS_SIZE)
real :: zef ! space to receive 08.15
#ifdef I_MPI_VERSION
#ifdef MPICH_VERSION
write (*,*) 'compiled with I_MPI_VERSION', I_MPI_VERSION, 'and MPICH_VERSION', MPICH_VERSION
#else
write (*,*) 'compiled with I_MPI_VERSION', I_MPI_VERSION
#endif
#else
#ifdef MPICH_VERSION
write (*,*) 'compiled with MPICH_VERSION', MPICH_VERSION
#endif
#endif
call MPI_Get_library_version(mpi_version_string, i, ierror)
write (*,*) 'running on library version ', trim(mpi_version_string)
atmos_comm = atmos_comm_in
call MPI_Comm_rank(atmos_comm, pe, ierror)
call MPI_Comm_size(atmos_comm, atm_npes, ierror)
mypid = getpid()
! Aarrggh. When started via slurm MPMD mode, get_attr(UNIVERSE_SIZE) yields segfault
!call MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, universe_size, flag);
!if (.not. flag) write(*,*) 'This MPI does not support UNIVERSE_SIZE.'
write(*,*) 'pid', mypid, 'atm task', pe, 'of', atm_npes, 'in a universe of size', universe_size
#ifdef MPMD_ATMOS
call MPI_Comm_size(MPI_COMM_WORLD, i, ierror)
if (atm_npes /= mpmd_other_npes) then
write(*,*) 'Error: atm_npes /= mpmd_other_npes', atm_npes, mpmd_other_npes
end if
inter_comm = MPI_COMM_WORLD
peer_pe = mpmd_fms_npes + pe
remote_size = atm_npes
write (*,*) 'pid',mypid,'task',pe,'peer task',peer_pe,'of MPMD world size',i
#else
! Now spawn the python-implemented atmos model
command = 'python3'
argv(1) = '-u'
argv(2) = '-m'
argv(3) = 'mpi4py'
argv(4) = 'aeolus2fms.py'
argv(5) = ' '
call MPI_Comm_spawn(command, argv, atm_npes, MPI_INFO_NULL, 0, atmos_comm, inter_comm, MPI_ERRCODES_IGNORE, ierror)
call MPI_Comm_size(inter_comm, inter_comm_size, ierror)
call MPI_Comm_rank(inter_comm, peer_pe, ierror)
call MPI_Comm_remote_size(inter_comm, remote_size, ierror)
write (*,*) 'pid',mypid,'task',pe,'is task',peer_pe,'of remotesize',remote_size,'in inter_comm'
!call MPI_Barrier(inter_comm, ierror)
! let python code print its hello message
!call MPI_Barrier(inter_comm, ierror)
#endif
allocate(remotepids(remote_size))
do i = 1,remote_size
call MPI_Recv(remotepids(i), 1, MPI_INT, MPI_ANY_SOURCE, 42, inter_comm, status, ierror)
write (*,*) 'F90 task',pe,'received pid',remotepids(i),'from task',status(MPI_SOURCE)
end do
!call MPI_Barrier(inter_comm, ierror)
if (mpmd_other_npes > 0) then; j = mpmd_fms_npes; else; j = 0; end if
do i = 1,remote_size
write(*,*) 'F90 task',pe,'sending mypid to task', j
call MPI_Send(mypid, 1, MPI_INT, j, 43, inter_comm, ierror)
j = j+1
end do
! Sigh. In the MPMD case, inter_comm is MPI_COMM_WORLD which includes ocn tasks.
! But those wont participate in the barrier.
! Workaround: dont do barrier here.
! Real solution: create a Communicator which excludes ocn tasks.
! But that requires sync with python code.
!write(*,*) 'aeolus2fms_interface_check entering first barrier' ; call flush(6)
!call MPI_Barrier(inter_comm, ierror)
! now call out into the python - implemented heart of Aeolus2
! first assemble some parameters with well-known values to verify
! that the F90<->python interface is OK.
do j=1,3
do i=1,2
testarray2d(i,j) = i+j/10.0
write (*,*) i,j,testarray2d(i,j)
end do
end do
!do k=1,4
! do j=1,3
! do i=1,2
! testarray3d(i,j,k) = i*100.0+j+k/10.0
! write (*,*) i,j,k,testarray3d(i,j,k)
! end do
! end do
!end do
write(*,*) 'MAXEXPONENT ', MAXEXPONENT(pitest) ; call flush(6)
write(*,*) 'aeolus2fms_interface_check sending deadbeef' ; call flush(6)
call MPI_Send(deadbeef, 1, MPI_INT, peer_pe, 44, inter_comm, ierror)
write(*,*) 'aeolus2fms_interface_check sending pitest' ; call flush(6)
call MPI_Send(pitest, 1, MPI_DOUBLE, peer_pe, 45, inter_comm, ierror)
!ierror = pyargs%setitem(3, true); errcheck
!ierror = pyargs%setitem(4, false); errcheck
write(*,*) 'aeolus2fms_interface_check sending testarray2d' ; call flush(6)
call MPI_Send(testarray2d, size(testarray2d), MPI_DOUBLE, peer_pe, 46, inter_comm, ierror)
!call MPI_Send(testarray3d, size(testarray3d), MPI_DOUBLE, peer_pe, 46, inter_comm, ierror)
!ierror = pyargs%setitem(6, kind_i); errcheck
!ierror = pyargs%setitem(7, kind_r); errcheck
!ierror = pyargs%setitem(8, kind_l); errcheck
!
!ierror = call_py_noret(aeolus2py, "interface_check", pyargs)
!errcheck
write(*,*) 'aeolus2fms_interface_check receiving one double' ; call flush(6)
call MPI_Recv(zef, 1, MPI_DOUBLE, MPI_ANY_SOURCE, 47, inter_comm, status, ierror)
if (8.15 /= zef) then
write(*,*) 'aeolus2fms_interface_check expected 8.15, received', zef; call flush(6)
end if
call MPI_Recv(response2d, size(response2d), MPI_DOUBLE, MPI_ANY_SOURCE, 48, inter_comm, status, ierror)
if (any(testarray2d /= response2d)) then
write(*,*) 'aeolus2fms_interface_check response2d does not match testarray2d' ; call flush(6)
do j=1,3
do i=1,2
write (*,*) i,j,testarray2d(i,j),response2d(i,j)
end do
end do
end if
deallocate(remotepids)
!write(*,*) 'aeolus2fms_interface_check entering final barrier' ; call flush(6)
!call MPI_Barrier(inter_comm, ierror)
write(*,*) 'aeolus2fms_interface_check finished' ; call flush(6)
end subroutine aeolus2fms_interface_check
subroutine aeolus2fms_init_grid( &
NoNx, NoNy, &
!NoNz, NoNz_Strato, &
lon_0_360_in, &
atmos_comm_in, pe_in, root_pe_in, atm_npes_in, &
is_in, ie_in, js_in, je_in &
)
integer, intent(in) :: NoNx, NoNy
logical, intent(in) :: lon_0_360_in
integer, intent(in) :: atmos_comm_in, pe_in, root_pe_in, atm_npes_in
integer, intent(in) :: is_in, ie_in, js_in, je_in
integer :: ierror
integer, dimension(7) :: gridparams
nlons_global = NoNx; nlats_global = NoNy
lon_0_360 = lon_0_360_in
atmos_comm = atmos_comm_in; pe = pe_in; root_pe = root_pe_in; atm_npes = atm_npes_in
is = is_in; ie = ie_in; js = js_in; je = je_in
! check on python side:
! - domain partitions and boundary indices
gridparams(1) = nlons_global
gridparams(2) = nlats_global
gridparams(3) = lon_0_360
gridparams(4) = is
gridparams(5) = ie
gridparams(6) = js
gridparams(7) = je
call MPI_Send(gridparams, size(gridparams), MPI_INT, peer_pe, 50, inter_comm, ierror)
!write (*,*) 'aeolus2fms_init_grid sent grid params' ; call flush(6)
write (*,*) 'aeolus2fms_init_grid finished' ; call flush(6)
end subroutine aeolus2fms_init_grid
subroutine aeolus2fms_get_axes_coords(lons, lonb, lats, latb) !, level, levelb, NoNx, NoNy, NoNz+NoNz_Strato)
real, dimension(:), intent(out) :: lons, lonb, lats, latb
integer :: status(MPI_STATUS_SIZE)
integer :: ierror
! Receive the _global_ lons, lonb, lats, latb arrays for setup of diag axes
write(*,*) 'expected global array sizes', size(lons), size(lonb), size(lats), size(latb)
write(*,*) 'aeolus2fms_get_axes_coords receiving axes values' ; call flush(6)
call MPI_Recv(lons, size(lons), MPI_DOUBLE, MPI_ANY_SOURCE, 51, inter_comm, status, ierror)
write(*,*) 'aeolus2fms_get_axes_coords received lons' ; call flush(6)
call MPI_Recv(lonb, size(lonb), MPI_DOUBLE, MPI_ANY_SOURCE, 52, inter_comm, status, ierror)
write(*,*) 'aeolus2fms_get_axes_coords received lonb' ; call flush(6)
call MPI_Recv(lats, size(lats), MPI_DOUBLE, MPI_ANY_SOURCE, 53, inter_comm, status, ierror)
write(*,*) 'aeolus2fms_get_axes_coords received lats' ; call flush(6)
call MPI_Recv(latb, size(latb), MPI_DOUBLE, MPI_ANY_SOURCE, 54, inter_comm, status, ierror)
write(*,*) 'aeolus2fms_get_axes_coords received latb' ; call flush(6)
end subroutine aeolus2fms_get_axes_coords
subroutine aeolus2fms_init( &
Time_init_year, Time_init_month, Time_init_day, Time_init_seconds, &
Time_days, Time_seconds, &
Time_step_days, Time_step_seconds, &
without_topo, &
HORO, &
SIGORO, &
land_frac, & ! the actual land_frac is only passed in the downward sweep
area, &
update_land_frac_always, &
nr_tracers_in, &
q_ind_in, &
co2_ind_in &
)
integer, intent(in) :: &
Time_init_year, Time_init_month, Time_init_day, Time_init_seconds, &
Time_days, Time_seconds, &
Time_step_days, Time_step_seconds
logical, intent(in) :: without_topo
real, dimension(:,:), intent(in) :: &
HORO, & ! Orography height, averaged over grid cell
SIGORO, & ! standard deviation of topography on local domain
land_frac,&! provisional land fraction mask. The real one is ...
area ! grid cell area
logical, intent(in) :: update_land_frac_always
integer, intent(in) :: nr_tracers_in, q_ind_in, co2_ind_in
integer :: ierror
integer, dimension(14) :: aeolus2params
nr_tracers = nr_tracers_in
q_ind = q_ind_in
co2_ind = co2_ind_in
aeolus2params(1) = Time_init_year
aeolus2params(2) = Time_init_month
aeolus2params(3) = Time_init_day
aeolus2params(4) = Time_init_seconds
aeolus2params(5) = Time_days
aeolus2params(6) = Time_seconds
aeolus2params(7) = Time_step_days
aeolus2params(8) = Time_step_seconds
aeolus2params(9) = without_topo
aeolus2params(10) = update_land_frac_always
aeolus2params(11) = nr_tracers
aeolus2params(12) = q_ind
aeolus2params(13) = co2_ind
aeolus2params(14) = 42 ! minimal interface check
call MPI_Send(aeolus2params, size(aeolus2params), MPI_INT, peer_pe, 60, inter_comm, ierror)
write(*,*) 'aeolus2fms_init sent params' ; call flush(6)
if (.not.without_topo) then
call MPI_Send(HORO, size(HORO), MPI_DOUBLE, peer_pe, 61, inter_comm, ierror)
write(*,*) 'aeolus2fms_init sent HORO' ; call flush(6)
call MPI_Send(SIGORO, size(SIGORO), MPI_DOUBLE, peer_pe, 62, inter_comm, ierror)
write(*,*) 'aeolus2fms_init sent SIGHORO' ; call flush(6)
end if
call MPI_Send(land_frac, size(land_frac), MPI_DOUBLE, peer_pe, 63, inter_comm, ierror)
write(*,*) 'aeolus2fms_init sent land_frac' ; call flush(6)
call MPI_Send(area, size(area), MPI_DOUBLE, peer_pe, 64, inter_comm, ierror)
write(*,*) 'aeolus2fms_init sent area' ; call flush(6)
write (*,*) 'aeolus2fms_init finished' ; call flush(6)
end subroutine aeolus2fms_init
subroutine aeolus2fms_atmosphere_down ( &
! input parameters &
Time_seconds, Time_days, &
dayoftheyear, &
frac_land, t_surf, albedo, &
albedo_vis_dir, albedo_nir_dir, &
albedo_vis_dif, albedo_nir_dif, &
rough_mom, &
u_star, b_star, q_star, &
!frac_open_sea, & ! non-seaice fraction (%)
dtau_du, dtau_dv, & ! derivatives of wind stress w.r.t. the lowest level wind speed
! inout parameters &
u_flux, v_flux, & ! wind stress
! output parameters &
gust, &
! coszen, cosz, solar are now input-parameters for Aeolus2
coszen, &
!coszen_radwt, &
solar, & ! here pass the 1-D variables.
flux_lw_sf_up, &
! output parameters &
flux_sw, &
flux_sw_dir, flux_sw_dif, &
flux_sw_down_vis_dir, &
flux_sw_down_vis_dif, &
flux_sw_down_total_dir, &
flux_sw_down_total_dif, &
flux_sw_vis, &
flux_sw_vis_dir, &
flux_sw_vis_dif, &
flux_lw, &
! output parameters from surf_diff_type fields &
delta_tr, &
dflux_tr, &
delta_t, &
dflux_t, &
dtmass, &
delta_u, &
delta_v &
)
integer, intent(in) :: Time_seconds, Time_days
integer, intent(in) :: dayoftheyear
real, intent(in), dimension(is:ie,js:je) :: frac_land, t_surf, albedo
real, intent(in), dimension(is:ie,js:je) :: albedo_vis_dir, albedo_nir_dir
real, intent(in), dimension(is:ie,js:je) :: albedo_vis_dif, albedo_nir_dif
real, intent(in), dimension(is:ie,js:je) :: rough_mom
real, intent(in), dimension(is:ie,js:je) :: u_star, b_star, q_star, dtau_du, dtau_dv
!real, intent(in), dimension(is:ie,js:je) :: frac_open_sea
real, intent(inout), dimension(is:ie,js:je) :: u_flux, v_flux
real, intent(out), dimension(is:ie,js:je) :: gust
real, intent(in), dimension(is:ie,js:je) :: coszen !, coszen_radwt
real, intent(in), dimension(js:je) :: solar
real, intent(in), dimension(is:ie,js:je) :: flux_lw_sf_up
real, intent(out), dimension(is:ie,js:je) :: flux_sw
real, intent(out), dimension(is:ie,js:je) :: flux_sw_dir, flux_sw_dif, flux_sw_down_vis_dir
real, intent(out), dimension(is:ie,js:je) :: flux_sw_down_vis_dif, flux_sw_down_total_dir
real, intent(out), dimension(is:ie,js:je) :: flux_sw_down_total_dif, flux_sw_vis
real, intent(out), dimension(is:ie,js:je) :: flux_sw_vis_dir, flux_sw_vis_dif
real, intent(out), dimension(is:ie,js:je) :: flux_lw
! third dimension is the tracer number, 1=humidity
real, intent(out), dimension(:,:,:) :: delta_tr
real, intent(out), dimension(:,:,:) :: dflux_tr
real, intent(out), dimension(is:ie,js:je) :: delta_t
real, intent(out), dimension(is:ie,js:je) :: dflux_t
real, intent(out), dimension(is:ie,js:je) :: dtmass
real, intent(out), dimension(is:ie,js:je) :: delta_u
real, intent(out), dimension(is:ie,js:je) :: delta_v
integer :: ierror
write (*,*) 'aeolus2fms_atmosphere_down starting at', Time_days, Time_seconds, dayoftheyear
! send all input parameters to aeolus2fms.py with tags 200ff
call MPI_Send(Time_seconds, 1, MPI_INT, peer_pe, 200, inter_comm, ierror)
call MPI_Send(Time_days, 1, MPI_INT, peer_pe, 201, inter_comm, ierror)
call MPI_Send(dayoftheyear, 1, MPI_INT, peer_pe, 202, inter_comm, ierror)
write (*,*) 'aeolus2fms_atmosphere_down sent Time info'
call MPI_Send(frac_land, size(frac_land), MPI_DOUBLE, peer_pe, 203, inter_comm, ierror)
call MPI_Send(t_surf, size(t_surf), MPI_DOUBLE, peer_pe, 204, inter_comm, ierror)
call MPI_Send(albedo, size(albedo), MPI_DOUBLE, peer_pe, 205, inter_comm, ierror)
call MPI_Send(albedo_vis_dir, size(albedo_vis_dir), MPI_DOUBLE, peer_pe, 206, inter_comm, ierror)
call MPI_Send(albedo_nir_dir, size(albedo_nir_dir), MPI_DOUBLE, peer_pe, 207, inter_comm, ierror)
call MPI_Send(albedo_vis_dif, size(albedo_vis_dif), MPI_DOUBLE, peer_pe, 208, inter_comm, ierror)
call MPI_Send(albedo_nir_dif, size(albedo_nir_dif), MPI_DOUBLE, peer_pe, 209, inter_comm, ierror)
call MPI_Send(rough_mom, size(rough_mom), MPI_DOUBLE, peer_pe, 210, inter_comm, ierror)
call MPI_Send(u_star, size(u_star), MPI_DOUBLE, peer_pe, 211, inter_comm, ierror)
call MPI_Send(b_star, size(b_star), MPI_DOUBLE, peer_pe, 212, inter_comm, ierror)
call MPI_Send(q_star, size(q_star), MPI_DOUBLE, peer_pe, 213, inter_comm, ierror)
call MPI_Send(dtau_du, size(dtau_du), MPI_DOUBLE, peer_pe, 214, inter_comm, ierror)
call MPI_Send(dtau_dv, size(dtau_dv), MPI_DOUBLE, peer_pe, 215, inter_comm, ierror)
call MPI_Send(u_flux, size(u_flux), MPI_DOUBLE, peer_pe, 216, inter_comm, ierror)
call MPI_Send(v_flux, size(v_flux), MPI_DOUBLE, peer_pe, 217, inter_comm, ierror)
call MPI_Send(coszen, size(coszen), MPI_DOUBLE, peer_pe, 218, inter_comm, ierror)
! solar is 1-D !
write(*,*) 'sending solar data size', size(solar)
call MPI_Send(solar, size(solar), MPI_DOUBLE, peer_pe, 219, inter_comm, ierror)
call MPI_Send(flux_lw_sf_up, size(flux_lw_sf_up), MPI_DOUBLE, peer_pe, 220, inter_comm, ierror)
write (*,*) 'aeolus2fms_atmosphere_down sent atmos arrays'
! receive output parameters
write (*,*) 'TODO aeolus2fms_atmosphere_down receive output parameters' ; call flush(6)
! (pass data as separate 2-D arrays for each tracer)
end subroutine aeolus2fms_atmosphere_down
subroutine aeolus2fms_atmosphere_up ( &
! input parameters
Time_year, Time_month, &
Time_seconds, Time_days, & ! seconds-of-day and days-since-time-axis-start
frac_land, &
delta_t, &
delta_tr, &
! output parameters
lprec, fprec, gust, &
! input parameters again
u_star, b_star, q_star &
)
integer, intent(in) :: Time_year, Time_month
integer, intent(in) :: Time_seconds, Time_days
real, intent(in), dimension(is:ie,js:je) :: frac_land
real, intent(in), dimension(is:ie,js:je) :: delta_t
! third dimension is the tracer number, 1=humidity
real, intent(in), dimension(:,:,:) :: delta_tr
real, intent(out), dimension(is:ie,js:je) :: lprec, fprec, gust
real, intent(in), dimension(is:ie,js:je) :: u_star, b_star, q_star
integer :: ierror
write (*,*) 'aeolus2fms_atmosphere_up starting at', Time_year, Time_month, Time_days, Time_seconds
! send all input parameters to aeolus2fms.py with tags 100ff
call MPI_Send(Time_year, 1, MPI_INT, peer_pe, 100, inter_comm, ierror)
call MPI_Send(Time_month, 1, MPI_INT, peer_pe, 101, inter_comm, ierror)
call MPI_Send(Time_seconds, 1, MPI_INT, peer_pe, 102, inter_comm, ierror)
call MPI_Send(Time_days, 1, MPI_INT, peer_pe, 103, inter_comm, ierror)
write (*,*) 'aeolus2fms_atmosphere_up sent Time info'
call MPI_Send(frac_land, size(frac_land), MPI_DOUBLE, peer_pe, 104, inter_comm, ierror)
call MPI_Send(delta_t, size(delta_t), MPI_DOUBLE, peer_pe, 105, inter_comm, ierror)
! delta_tr is 3-D !
call MPI_Send(delta_tr(:,:,1),size(delta_tr(:,:,1)),MPI_DOUBLE, peer_pe, 106, inter_comm, ierror)
call MPI_Send(u_star, size(u_star), MPI_DOUBLE, peer_pe, 107, inter_comm, ierror)
call MPI_Send(b_star, size(b_star), MPI_DOUBLE, peer_pe, 108, inter_comm, ierror)
call MPI_Send(q_star, size(q_star), MPI_DOUBLE, peer_pe, 109, inter_comm, ierror)
write (*,*) 'aeolus2fms_atmosphere_up sent atmos arrays'
! receive output parameters
write (*,*) 'TODO aeolus2fms_atmosphere_up receive output parameters' ; call flush(6)
end subroutine aeolus2fms_atmosphere_up
subroutine aeolus2fms_finish(Time_seconds, Time_days)
integer, intent(in) :: Time_seconds, Time_days
integer :: ierror
integer, dimension(2) :: aeolus2params
aeolus2params(1) = Time_seconds
aeolus2params(2) = Time_days
call MPI_Send(aeolus2params, size(aeolus2params), MPI_INT, peer_pe, 72, inter_comm, ierror)
write(*,*) 'aeolus2fms_finish sent params' ; call flush(6)
end subroutine aeolus2fms_finish
subroutine aeolus2fms_restart(Time_seconds, Time_days)
integer, intent(in) :: Time_seconds, Time_days
integer :: ierror
integer, dimension(2) :: aeolus2params
aeolus2params(1) = Time_seconds
aeolus2params(2) = Time_days
call MPI_Send(aeolus2params, size(aeolus2params), MPI_INT, peer_pe, 73, inter_comm, ierror)
write(*,*) 'aeolus2fms_restart sent params' ; call flush(6)
end subroutine aeolus2fms_restart
! subroutine aeolus2fms_get_boundary(lon_boundaries, lat_boundaries, local, &
! lbound(lon_boundaries, dim=1), ubound(lon_boundaries, dim=1), &
! lbound(lon_boundaries, dim=2), ubound(lon_boundaries, dim=2), &
! lbound(lat_boundaries, dim=1), ubound(lat_boundaries, dim=1), &
! lbound(lat_boundaries, dim=2), ubound(lat_boundaries, dim=2))
! end subroutine aeolus2fms_get_boundary
subroutine aeolus2fms_get_bottom_mass(t_bot, tr_bot, p_bot, z_bot, p_surf, slp)
real, intent(out), dimension(is:ie,js:je) :: t_bot, p_bot, z_bot, p_surf, slp
real, intent(out), dimension(:,:,:) :: tr_bot
integer :: ierror, ierror2, status(MPI_STATUS_SIZE), count
integer :: dummy = 42
call MPI_Send(dummy, 1, MPI_INT, peer_pe, 80, inter_comm, ierror)
write(*,*) 'aeolus2fms_get_bottom_mass sent request' ; call flush(6)
call MPI_Recv(t_bot, size(t_bot), MPI_DOUBLE, MPI_ANY_SOURCE, 81, inter_comm, status, ierror)
call MPI_Get_count(status, MPI_DOUBLE, count, ierror2)
write(*,*) 'Received t_bot count ',count,' from ',status(MPI_SOURCE),' tag ',status(MPI_TAG)
if (ierror /= MPI_SUCCESS) call print_mpi_error('t_bot', size(t_bot), MPI_DOUBLE, 81, status, ierror)
call MPI_Recv(tr_bot(:,:,q_ind), size(tr_bot(:,:,q_ind)), MPI_DOUBLE, MPI_ANY_SOURCE, 82, inter_comm, status, ierror)
if (ierror /= MPI_SUCCESS) call print_mpi_error('tr_bot_qind', size(tr_bot(:,:,q_ind)), MPI_DOUBLE, 82, status, ierror)
call MPI_Recv(p_bot, size(p_bot), MPI_DOUBLE, MPI_ANY_SOURCE, 83, inter_comm, status, ierror)
if (ierror /= MPI_SUCCESS) call print_mpi_error('p_bot', size(p_bot), MPI_DOUBLE, 83, status, ierror)
call MPI_Recv(z_bot, size(z_bot), MPI_DOUBLE, MPI_ANY_SOURCE, 84, inter_comm, status, ierror)
call MPI_Get_count(status, MPI_DOUBLE, count, ierror2)
write(*,*) 'Received z_bot count ',count,' from ',status(MPI_SOURCE),' tag ',status(MPI_TAG)
if (ierror /= MPI_SUCCESS) call print_mpi_error('z_bot', size(z_bot), MPI_DOUBLE, 84, status, ierror)
call MPI_Recv(p_surf, size(p_surf), MPI_DOUBLE, MPI_ANY_SOURCE, 85, inter_comm, status, ierror)
if (ierror /= MPI_SUCCESS) call print_mpi_error('p_surf', size(p_surf), MPI_DOUBLE, 85, status, ierror)
call MPI_Recv(slp, size(slp), MPI_DOUBLE, MPI_ANY_SOURCE, 86, inter_comm, status, ierror)
if (ierror /= MPI_SUCCESS) call print_mpi_error('slp', size(slp), MPI_DOUBLE, 86, status, ierror)
if (co2_ind /= NO_TRACER) &
call MPI_Recv(tr_bot(:,:,co2_ind), size(tr_bot(:,:,co2_ind)), MPI_DOUBLE, MPI_ANY_SOURCE, 87, inter_comm, status, ierror)
write(*,*) 'aeolus2fms_get_bottom_mass received output parameters' ; call flush(6)
end subroutine aeolus2fms_get_bottom_mass
subroutine aeolus2fms_get_bottom_wind(u_bot, v_bot)
real, intent(out), dimension(is:ie,js:je) :: u_bot, v_bot
integer :: ierror, status(MPI_STATUS_SIZE)
integer :: dummy = 42
call MPI_Send(dummy, 1, MPI_INT, peer_pe, 90, inter_comm, ierror)
write(*,*) 'aeolus2fms_get_bottom_wind sent request' ; call flush(6)
call MPI_Recv(u_bot, size(u_bot), MPI_DOUBLE, MPI_ANY_SOURCE, 91, inter_comm, status, ierror)
call MPI_Recv(v_bot, size(v_bot), MPI_DOUBLE, MPI_ANY_SOURCE, 92, inter_comm, status, ierror)
write(*,*) 'aeolus2fms_get_bottom_wind received output parameters' ; call flush(6)
end subroutine aeolus2fms_get_bottom_wind
subroutine aeolus2fms_get_stock_pe(idx, val)
integer, intent(in) :: idx
real, intent(out) :: val
integer :: ierror, status(MPI_STATUS_SIZE)
call MPI_Send(idx, 1, MPI_INT, peer_pe, 70, inter_comm, ierror)
write(*,*) 'aeolus2fms_get_stock_pe request', idx ; call flush(6)
call MPI_Recv(val, 1, MPI_DOUBLE, MPI_ANY_SOURCE, 70, inter_comm, status, ierror)
write(*,*) 'aeolus2fms_get_stock_pe got response', val ; call flush(6)
end subroutine aeolus2fms_get_stock_pe
subroutine print_mpi_error(name, len, typ, tag, status, ierror)
character(*), intent(in) :: name
integer, intent(in) :: len, typ, tag, status(MPI_STATUS_SIZE), ierror
integer :: count, class, strlen, ierror2
character(len=MPI_MAX_ERROR_STRING) :: errstring, classtring
write(*,*) 'MPI_Recv for ',name,len,tag,' returned error ',ierror,' &
status[SOURCE,TAG,ERROR] ',status(MPI_SOURCE),status(MPI_TAG),status(MPI_ERROR)
call MPI_Get_count(status, typ, count, ierror2)
write(*,*) ' received ',count,' elements of type ',typ
call MPI_Error_class(ierror,class, ierror2)
call MPI_Error_string(ierror,errstring,strlen,ierror2)
call MPI_Error_string(class,classtring,strlen,ierror2)
write(*,*) ' ierror ',ierror,errstring,' is class ',class,classtring
call flush(6)
end subroutine print_mpi_error
end module aeolus2fms_mod