diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000..1a960a9 --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,130 @@ +cmake_minimum_required(VERSION 3.2) +#policy CMP0076 - target_sources source files are relative to file where target_sources is run +cmake_policy (SET CMP0076 NEW) + +option(BUILD_PT_COUPLING "Build the PyTorch coupling code") +option(BUILD_TF_COUPLING "Build the TensorFlow coupling code") +option(BUILD_FORPY_COUPLING "Build the Forpy coupling code") + +# MiMA claims to only compile with ifort / icc currently. +set ( CMAKE_Fortran_COMPILER "ifort" ) +set ( CMAKE_C_COMPILER "icc" ) +project(MiMA Fortran C) + +if(NOT CMAKE_BUILD_TYPE) + set(CMAKE_BUILD_TYPE Debug CACHE STRING "" FORCE) +endif() + +# Generate the main mima.x executable with dirs, libs, and opts +add_executable ( mima.x ) +target_include_directories( mima.x PUBLIC src/shared/include src/shared/mpp/include ) +add_library( mima_c ) # The C parts of MiMA, so we can apply different options for them. +target_compile_definitions( mima_c PRIVATE __IFC ) +target_compile_definitions( mima.x PRIVATE use_libMPI use_netCDF gFortran ) # gFortran appears to be unused + +# Also generate the postprocessing executable +add_executable ( mppnccombine postprocessing/mppnccombine.c ) + +#Add cmake directory to the environment module variable +list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake") + +# Set to install in bin directory as per current MiMA behaviour +if(CMAKE_INSTALL_PREFIX_INITIALIZED_TO_DEFAULT) + set(CMAKE_INSTALL_PREFIX "${CMAKE_SOURCE_DIR}/bin" CACHE PATH "..." FORCE) +endif() + +# Find MPI and OpenMP libraries and link +find_package (MPI REQUIRED) +target_link_libraries( mima.x PRIVATE MPI::MPI_Fortran ) + +find_package (OpenMP REQUIRED COMPONENTS Fortran) +target_link_libraries( mima.x PRIVATE OpenMP::OpenMP_Fortran ) + +# Find any libraries as neccesary for ML and link +# FIXME this is a bit clunky. I think we will have to have +# #ifdefs in the code, so may as well use them for this. +# Also this setup precludes having multiple methods compiled in. +if(BUILD_PT_COUPLING) + find_package(FTorch) + target_link_libraries( mima.x PRIVATE FTorch::ftorch ) + message(STATUS "Building with the Fortran PyTorch coupling") + + # point the pytorch coupling routines at mima + target_sources( mima.x PRIVATE src/atmos_param/cg_drag/pytorch.f90) +endif() +if(BUILD_TF_COUPLING) + find_package(FortranTensorFlow) + target_link_libraries( mima.x PRIVATE FortranTensorFlow::fortran-tf) + message( STATUS "Building with Fortran TensorFlow coupling") + + # point the pytorch coupling routines at mima + target_sources( mima.x PRIVATE src/atmos_param/cg_drag/tensorflow.f90) +endif() +if(BUILD_FORPY_COUPLING) + # Make sure python present + find_package (Python REQUIRED COMPONENTS Development) + target_link_libraries( mima.x PRIVATE Python::Python ) + + target_sources( mima.x PRIVATE src/shared/forpy/forpy_mod.f90) + target_sources( mima.x PRIVATE src/atmos_param/cg_drag/forpy.f90) +endif() +if(NOT (BUILD_PT_COUPLING OR BUILD_TF_COUPLING OR BUILD_FORPY_COUPLING)) + target_sources( mima.x PRIVATE src/atmos_param/cg_drag/null.f90) +endif() + +# Find the NetCDF installations and set the relevant variables for compilation +# Then link to executables +# Requires more legwork as NetCDF not provided by default +find_package(PkgConfig) +pkg_search_module(NETCDF_FORTRAN netcdf-fortran) +if (NETCDF_FORTRAN_FOUND) + set(NETCDF_LIBRARIES "${NETCDF_FORTRAN_LDFLAGS}") + set(NETCDF_INCLUDES "${NETCDF_FORTRAN_INCLUDE_DIRS}") +else() + set(NETCDF_F90 "YES") + find_package(NetCDF REQUIRED) +endif() +pkg_search_module(NETCDF_C netcdf) +if (NETCDF_C_FOUND) + list(APPEND NETCDF_LIBRARIES "${NETCDF_C_LDFLAGS}") + list(APPEND NETCDF_INCLUDES "${NETCDF_C_INCLUDE_DIRS}") +endif() + +target_link_libraries( mima.x PRIVATE mima_c ${NETCDF_LIBRARIES} ) +target_include_directories( mima.x PRIVATE ${NETCDF_INCLUDES} ) +target_link_libraries( mppnccombine PRIVATE ${NETCDF_LIBRARIES} ) +target_include_directories( mppnccombine PRIVATE ${NETCDF_INCLUDES} ) + +# Add various subdirectories with long lists of source files +add_subdirectory( src/coupler ) +add_subdirectory( src/atmos_coupled ) +add_subdirectory( src/atmos_param ) + +set_source_files_properties ( +# The following files do nothing but assign very large arrays. +# For some reason when compiling with ifort and optimisation +# the compilation will take a very long time (10s of minutes). +# Since the code doesn't actually *do* anything there's no +# need to waste time having the compiler apply probably +# meaningless optimisation. So we disable optimisation for these +# files. +src/atmos_param/rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_k_g.f90 +src/atmos_param/rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_k_g.f90 +PROPERTIES +COMPILE_FLAGS -O0 +) +add_subdirectory( src/atmos_shared ) +add_subdirectory( src/atmos_spectral ) +add_subdirectory( src/ice_param ) +# include/fms_platform.h +add_subdirectory( src/shared ) + +# Set coompile options for executable +target_compile_options( mima.x PRIVATE +-fpp +-safe-cray-ptr +-ftz +-assume byterecl +-i4 +-r8 +) diff --git a/README.md b/README.md index 500e3b2..56abc2a 100644 --- a/README.md +++ b/README.md @@ -26,3 +26,36 @@ AM2 is distributed under a GNU GPLv2 license. That means you have permission to RRTM/RRTMG: Copyright © 2002-2010, Atmospheric and Environmental Research, Inc. (AER, Inc.). This software may be used, copied, or redistributed as long as it is not sold and this copyright notice is reproduced on each copy made. This model is provided as is without any express or implied warranties. + + +## Building for Machine Learning + +### PyTorch +* Requires the fortran-pytorch library available [here](https://github.com/Cambridge-ICCS/fortran-pytorch-lib) +* Build with: + + cmake -DTorch_DIR=/lib/python3.11/site-packages/torch/share/cmake/Torc + +* Build MiMA using: + +### TensorFlow +* Requires the fortran-pytorch library available [here](https://github.com/Cambridge-ICCS/fortran-tf-lib) +* Requires TensorFlow C API: + + FILENAME=libtensorflow-cpu-linux-x86_64-2.11.0.tar.gz + wget -q --no-check-certificate https://storage.googleapis.com/tensorflow/libtensorflow/${FILENAME} + tar -C -xzf ${FILENAME} + +* Build with: + + cmake .. -DTENSORFLOW_LOCATION= -DCMAKE_Fortran_COMPILER=ifort -DCMAKE_C_COMPILER=icc -DCMAKE_BUILD_TYPE=Release + +### Forpy +* Requires a python venv with TensorFlow/PyTorch (and any other requirements) installed. + +### MiMA +* Build with + + cmake -DFLAG_FOR_ML .. + +where `-DFLAG_FOR_ML` is one of `-DBUILD_PT_COUPLING`, `-DBUILD_TF_COUPLING`, `-DBUILD_FORPY_COUPLING` diff --git a/cmake/FindNetCDF.cmake b/cmake/FindNetCDF.cmake new file mode 100644 index 0000000..d1082d6 --- /dev/null +++ b/cmake/FindNetCDF.cmake @@ -0,0 +1,78 @@ +# - Find NetCDF +# Find the native NetCDF includes and library +# +# NETCDF_INCLUDES - where to find netcdf.h, etc +# NETCDF_LIBRARIES - Link these libraries when using NetCDF +# NETCDF_FOUND - True if NetCDF found including required interfaces (see below) +# +# Your package can require certain interfaces to be FOUND by setting these +# +# NETCDF_CXX - require the C++ interface and link the C++ library +# NETCDF_F77 - require the F77 interface and link the fortran library +# NETCDF_F90 - require the F90 interface and link the fortran library +# +# The following are not for general use and are included in +# NETCDF_LIBRARIES if the corresponding option above is set. +# +# NETCDF_LIBRARIES_C - Just the C interface +# NETCDF_LIBRARIES_CXX - C++ interface, if available +# NETCDF_LIBRARIES_F77 - Fortran 77 interface, if available +# NETCDF_LIBRARIES_F90 - Fortran 90 interface, if available +# +# Normal usage would be: +# set (NETCDF_F90 "YES") +# find_package (NetCDF REQUIRED) +# target_link_libraries (uses_f90_interface ${NETCDF_LIBRARIES}) +# target_link_libraries (only_uses_c_interface ${NETCDF_LIBRARIES_C}) + +if (NETCDF_INCLUDES AND NETCDF_LIBRARIES) + # Already in cache, be silent + set (NETCDF_FIND_QUIETLY TRUE) +endif (NETCDF_INCLUDES AND NETCDF_LIBRARIES) + +#set(CMAKE_FIND_DEBUG_MODE TRUE) +find_path (NETCDF_INCLUDES netcdf.h netcdf.mod netcdf.inc + HINTS NETCDF_DIR ENV NETCDF_DIR ENV CPATH ENV FPATH) +#set(CMAKE_FIND_DEBUG_MODE FALSE) +message (STATUS "so far NETCDF_INCLUDES: ${NETCDF_INCLUDES}") + + +find_library (NETCDF_LIBRARIES_C NAMES netcdf netcdff + HINTS ENV LD_LIBRARY_PATH LIBRARY_PATH) +mark_as_advanced(NETCDF_LIBRARIES_C) +message (STATUS "so far NETCDF_LIBRARIES_C: ${NETCDF_LIBRARIES_C}") + + +set (NetCDF_has_interfaces "YES") # will be set to NO if we're missing any interfaces +set (NetCDF_libs "${NETCDF_LIBRARIES_C}") + +get_filename_component (NetCDF_lib_dirs "${NETCDF_LIBRARIES_C}" PATH) + +macro (NetCDF_check_interface lang header libs) + if (NETCDF_${lang}) + find_path (NETCDF_INCLUDES_${lang} NAMES ${header} + HINTS "${NETCDF_INCLUDES}" NO_DEFAULT_PATH) + find_library (NETCDF_LIBRARIES_${lang} NAMES ${libs} + HINTS "${NetCDF_lib_dirs}" NO_DEFAULT_PATH) + mark_as_advanced (NETCDF_INCLUDES_${lang} NETCDF_LIBRARIES_${lang}) + if (NETCDF_INCLUDES_${lang} AND NETCDF_LIBRARIES_${lang}) + list (INSERT NetCDF_libs 0 ${NETCDF_LIBRARIES_${lang}}) # prepend so that -lnetcdf is last + else (NETCDF_INCLUDES_${lang} AND NETCDF_LIBRARIES_${lang}) + set (NetCDF_has_interfaces "NO") + message (STATUS "Failed to find NetCDF interface for ${lang}") + endif (NETCDF_INCLUDES_${lang} AND NETCDF_LIBRARIES_${lang}) + endif (NETCDF_${lang}) +endmacro (NetCDF_check_interface) + +NetCDF_check_interface (CXX netcdfcpp.h netcdf_c++) +NetCDF_check_interface (F77 netcdf.inc netcdff) +NetCDF_check_interface (F90 netcdf.mod netcdff) + +set (NETCDF_LIBRARIES "${NetCDF_libs}" CACHE STRING "All NetCDF libraries required for interface level") + +# handle the QUIETLY and REQUIRED arguments and set NETCDF_FOUND to TRUE if +# all listed variables are TRUE +include (FindPackageHandleStandardArgs) +find_package_handle_standard_args (NetCDF DEFAULT_MSG NETCDF_LIBRARIES NETCDF_INCLUDES NetCDF_has_interfaces) + +mark_as_advanced (NETCDF_LIBRARIES NETCDF_INCLUDES) diff --git a/docs/GettingStarted.md b/docs/GettingStarted.md index 82387c9..e2bf9e9 100644 --- a/docs/GettingStarted.md +++ b/docs/GettingStarted.md @@ -16,13 +16,57 @@ Get the latest version from [GitHub](https://github.com/mjucker/MiMA/releases/la * The code in its present form will only compile with Intel `ifort` and `icc` compilers. This description will assume `ifort` and `icc` are available. * MiMA reads and writes to `netCDF`, so `netCDF` needs to be installed on the system. * Being parallel, `MPI` needs to be there too. - * The flags need to be adjusted in the `bin/mkmf.template.$PLATFORM` file of choice. Typically, `$PLATFORM` will be slightly different on each machine, as libraries may not be found at the same location. -* Compilation flags: The relevant flags are defined in `bin/mkmf.template.$PLATFORM`, and might or might not use environment variables. For instance, `netCDF` libraries or debug flags could be read from environment variables for more dynamic compilation. The first thing to do is to create an appropriate `mkmf.template.something`, which contains the relevant flags. Look at some of the template files that are already there to get an idea how to set the flags. +* Build Systems + * There are two build systems that may be used to compile MiMA, CMake, and `mkmf`. + * Instructions for building with both of these are provided below. -* Compile script: A compilescript is provided in `exp/compilescript.csh`. Make sure to set the first variable, `platform`, to whatever name you gave the mkmf template in the previous step. In our example, set it to `something`. The output executable will be in `exp/exec.$PLATFORM/mima.x` +### CMake +Building using CMake should follow the same process, regardless of the platform MiMA is being built on. -* Adding files: If you work on your own version of MiMA, make sure every extension is in a new file, so as to not disturb the main branch and any other fork that might exist. When adding a source file, add the path to the file in `exp/path_names`, and it will be compiled the next time you run `./compilescript.csh`. +* Dependencies + * In addition to the above list, building with CMake requires `cmake` to be installed on the system. + +* To build MiMA using CMake after cloning the repository and navigating into it (e.g. via `cd MiMA/`) run the following commands: + ``` + mkdir build + cd build + cmake .. + make + ``` + This takes you into the MiMA directory, creates a build directory, runs the CMake script `CMakeLists.txt` to generate a makefile for the system and then builds using the makefile. + +* The output executable will be at `build/mima.x` + +### mkmf +Building using mkmf requires the user to amend the `compilescript.csh` scipt as appropriate for the platform they are building on, and possibly defining a mkmf template for their platform. + +* MiMA can be built using mkmf via the following steps: + + * Select the appropriate mkmf template file for your platform from `bin/`. + These are of the form `bin/mkmf.template.$PLATFORM`, where `$PLATFORM` is typically slightly different on each machine as libraries may not be found at the same locations. + + * Adjust the relevant compilation flags in the `bin/mkmf.template.$PLATFORM` file of choice as appropriate. + * These may or may not use environment variables. For instance, `netCDF` libraries or debug flags could be read from environment variables for more dynamic compilation. The first thing to do is to create an appropriate `mkmf.template.something`, which contains the relevant flags. Look at some of the template files that are already there to get an idea how to set the flags. + + * Compile script: A compilescript is provided in `exp/compilescript.csh`. Make sure to set the first variable, `platform`, to match the `$PLATFORM` of the mkmf template in the previous step. In our example, set it to `something`. + + * MiMA can now be built with the following commands: + ``` + cd exp + ./compilescript.csh + ``` + +* The output executable will be in `exp/exec.$PLATFORM/mima.x` + + +### Adding files to the build process + +* If you work on your own version of MiMA, make sure every extension is in a new file, so as to not disturb the main branch and any other fork that might exist. +* When adding a source file you should: + * add the file to the `CMakeLists.txt` file in its local directory, + * add the path to the file in `exp/path_names`, + To ensure that it will be compiled the next time you build using CMake or run `./compilescript.csh`. ## Test run diff --git a/input/input.nml b/input/input.nml index afb5152..682717d 100644 --- a/input/input.nml +++ b/input/input.nml @@ -128,7 +128,10 @@ weightminus2 = 0.02, source_level_pressure = 315.e+02, damp_level_pressure = 0.85e+02, - cg_drag_freq = 21600 / + cg_drag_freq = 21600, + runML = .true., + model_dir = 'unknown', + model_name = 'unknown.ext'/ &moist_processes_nml do_bm =.true., diff --git a/input_ad.nml b/input_ad.nml new file mode 100644 index 0000000..c0a3612 --- /dev/null +++ b/input_ad.nml @@ -0,0 +1,220 @@ +&coupler_nml + days = 360, + dt_atmos =500, + current_date = 0001,1,1,0,0,0 + calendar = 'thirty_day' / + +# Note: damping_order = 4 specifies del 8'th diffusion + &spectral_dynamics_nml + damping_option = 'resolution_dependent', + damping_order = 4, + do_mass_correction =.true., + do_energy_correction =.true., + do_water_correction =.true., + water_correction_limit = 200.e2, + initial_sphum = 2.e-06, + use_virtual_temperature =.false., + vert_advect_uv = 'second_centered', + vert_advect_t = 'second_centered', + use_implicit = .true., + longitude_origin = 0., + robert_coeff = .03, + alpha_implicit = .5, + reference_sea_level_press=1.e5, + lon_max = 128, + lat_max = 64, + num_levels = 40, + num_fourier = 42, + num_spherical = 43, + fourier_inc = 1, + triang_trunc =.true., + topography_option = 'interpolated', + ocean_topog_smoothing = 0.995, + vert_coord_option = 'uneven_sigma', + surf_res = 0.1, + scale_heights = 7.9, + exponent = 1.4 / + + +# Empty namelist causes all values to take on default values. + + &spectral_init_cond_nml + initial_temperature = 264. / + +---------- physics namelists -------------- + + &rrtm_radiation_nml + h2o_lower_limit = 2.e-07, + co2ppmv = 390., + do_read_ozone = .true., + ozone_file = 'ozone_1990', + dt_rad_avg = 4500, + dt_rad = 4500, + lonstep = 4 / + + &astro_nml + solr_cnst = 1370. / + + &simple_surface_nml + do_qflux = .true., + surface_choice = 1, + Tm = 285., + heat_capacity = 3.e08, + land_capacity = 1.e07, + trop_capacity = 1.e08, + trop_cap_limit = 20. + const_albedo = 0.23, + albedo_choice = 7, + albedo_wdth = 5, + higher_albedo = 0.80, + albedo_cntrNH = 68., + albedo_cntrSH = 64., + lat_glacier = -70, + land_option = 'interpolated', + do_warmpool = .true., + roughness_choice = 4, + mom_roughness_land = 5.e3, + q_roughness_land = 1.e-12 / + +&qflux_nml + qflux_amp = 26., + warmpool_localization_choice = 3, + warmpool_k = 1.66666, + warmpool_amp = 18., + warmpool_width = 35., + qflux_width = 16., + warmpool_phase = 140., + warmpool_centr = 0., + gulf_k = 4.0, + gulf_amp = 70., + kuroshio_amp = 40., + trop_atlantic_amp = 50., + gulf_phase = 310., + Hawaiiextra = 30.0, + Pac_ITCZextra = -0.0, + north_sea_heat =0.0/ + + &damping_driver_nml + do_rayleigh = .false., + trayfric = -0.5, + sponge_pbottom= 50., + do_conserve_energy = .true., + do_cg_drag = .true., + do_mg_drag = .false./ + +&topography_nml + topog_file = 'INPUT/navy_topography.data.nc', + water_file = 'INPUT/navy_pctwater.data.nc' / + + + &cg_drag_nml + Bt_0 = 0.0043, + Bt_nh = 0.00, + Bt_eq = 0.0043, + Bt_sh = 0.00, + phi0n = 15., + phi0s =-15., + dphin = 10., + dphis =-10., + flag=0, + Bw = 0.4, + Bn = 0.0, + cw = 35.0, + cwtropics = 35.0, + cn = 2.0, + kelvin_kludge = 1.0, + weighttop = 0.7, + weightminus1 = 0.28, + weightminus2 = 0.02, + source_level_pressure = 315.e+02, + damp_level_pressure = 0.85e+02, + cg_drag_freq = 21600, + runML = .false., + model_dir = '/home/sjc306/hpc-work/Datawave/MiMA/src/shared/tensorflow/', + model_name = 'saved_model'/ + + &moist_processes_nml + do_bm =.true., + do_bmmass =.false., + do_bmomp =.false., + do_mca =.false., + do_lsc =.true., + do_strat =.false., + do_ras =.false., + do_diag_clouds =.false., + do_rh_clouds =.false., + use_df_stuff = .true. / + + &betts_miller_nml + tau_bm = 7200., + rhbm = .7 , + do_simp = .false., + do_shallower = .true., + do_changeqref = .false., + do_envsat = .false., + do_taucape = .false., + capetaubm = 900., + tau_min = 2400./ + +&moist_conv_nml + beta = 0.0, + use_df_stuff = .true./ + + &monin_obukhov_nml + rich_crit = 2.0, + drag_min = 4.e-05 / + + + + &lscale_cond_nml + do_evap = .true., + use_df_stuff = .true. / + + &vert_diff_driver_nml + do_conserve_energy = .true., + use_virtual_temp_vert_diff = .false. / + + + + &diffusivity_nml + do_entrain = .false + use_df_stuff = .true. / + + &surface_flux_nml + use_virtual_temp = .false., + use_df_stuff = .true., + old_dtaudv = .true., + gust_const = 1.0 / + + + + &vert_turb_driver_nml + use_tau = .false., + gust_scheme = 'constant', + constant_gust = 0., + do_mellor_yamada = .false., + do_shallow_conv = .false., + use_df_stuff = .true., + do_diffusivity = .true./ + + &ocean_rough_nml + rough_scheme = 'beljaars' / + + &physics_driver_nml + do_grey_radiation = .false., + do_rrtm_radiation = .true., + do_damping = .true. / + +# domains_stack_size will vary for different model resolutions, +# domain decompositions, and number of processors used. + +&fms_nml + domains_stack_size = 600000 / + + &fms_io_nml + threading_write = 'single', + fileset_write = 'single' / + + + + diff --git a/input_fp_pt.nml b/input_fp_pt.nml new file mode 100644 index 0000000..865f118 --- /dev/null +++ b/input_fp_pt.nml @@ -0,0 +1,220 @@ +&coupler_nml + days = 10, + dt_atmos =500, + current_date = 0001,1,1,0,0,0 + calendar = 'thirty_day' / + +# Note: damping_order = 4 specifies del 8'th diffusion + &spectral_dynamics_nml + damping_option = 'resolution_dependent', + damping_order = 4, + do_mass_correction =.true., + do_energy_correction =.true., + do_water_correction =.true., + water_correction_limit = 200.e2, + initial_sphum = 2.e-06, + use_virtual_temperature =.false., + vert_advect_uv = 'second_centered', + vert_advect_t = 'second_centered', + use_implicit = .true., + longitude_origin = 0., + robert_coeff = .03, + alpha_implicit = .5, + reference_sea_level_press=1.e5, + lon_max = 128, + lat_max = 64, + num_levels = 40, + num_fourier = 42, + num_spherical = 43, + fourier_inc = 1, + triang_trunc =.true., + topography_option = 'interpolated', + ocean_topog_smoothing = 0.995, + vert_coord_option = 'uneven_sigma', + surf_res = 0.1, + scale_heights = 7.9, + exponent = 1.4 / + + +# Empty namelist causes all values to take on default values. + + &spectral_init_cond_nml + initial_temperature = 264. / + +---------- physics namelists -------------- + + &rrtm_radiation_nml + h2o_lower_limit = 2.e-07, + co2ppmv = 390., + do_read_ozone = .true., + ozone_file = 'ozone_1990', + dt_rad_avg = 4500, + dt_rad = 4500, + lonstep = 4 / + + &astro_nml + solr_cnst = 1370. / + + &simple_surface_nml + do_qflux = .true., + surface_choice = 1, + Tm = 285., + heat_capacity = 3.e08, + land_capacity = 1.e07, + trop_capacity = 1.e08, + trop_cap_limit = 20. + const_albedo = 0.23, + albedo_choice = 7, + albedo_wdth = 5, + higher_albedo = 0.80, + albedo_cntrNH = 68., + albedo_cntrSH = 64., + lat_glacier = -70, + land_option = 'interpolated', + do_warmpool = .true., + roughness_choice = 4, + mom_roughness_land = 5.e3, + q_roughness_land = 1.e-12 / + +&qflux_nml + qflux_amp = 26., + warmpool_localization_choice = 3, + warmpool_k = 1.66666, + warmpool_amp = 18., + warmpool_width = 35., + qflux_width = 16., + warmpool_phase = 140., + warmpool_centr = 0., + gulf_k = 4.0, + gulf_amp = 70., + kuroshio_amp = 40., + trop_atlantic_amp = 50., + gulf_phase = 310., + Hawaiiextra = 30.0, + Pac_ITCZextra = -0.0, + north_sea_heat =0.0/ + + &damping_driver_nml + do_rayleigh = .false., + trayfric = -0.5, + sponge_pbottom= 50., + do_conserve_energy = .true., + do_cg_drag = .true., + do_mg_drag = .false./ + +&topography_nml + topog_file = 'INPUT/navy_topography.data.nc', + water_file = 'INPUT/navy_pctwater.data.nc' / + + + &cg_drag_nml + Bt_0 = 0.0043, + Bt_nh = 0.00, + Bt_eq = 0.0043, + Bt_sh = 0.00, + phi0n = 15., + phi0s =-15., + dphin = 10., + dphis =-10., + flag=0, + Bw = 0.4, + Bn = 0.0, + cw = 35.0, + cwtropics = 35.0, + cn = 2.0, + kelvin_kludge = 1.0, + weighttop = 0.7, + weightminus1 = 0.28, + weightminus2 = 0.02, + source_level_pressure = 315.e+02, + damp_level_pressure = 0.85e+02, + cg_drag_freq = 21600, + runML = .true., + model_dir = '/home/sjc306/hpc-work/Datawave/MiMA/src/shared/pytorch/', + model_name = 'run_emulator_davenet'/ + + &moist_processes_nml + do_bm =.true., + do_bmmass =.false., + do_bmomp =.false., + do_mca =.false., + do_lsc =.true., + do_strat =.false., + do_ras =.false., + do_diag_clouds =.false., + do_rh_clouds =.false., + use_df_stuff = .true. / + + &betts_miller_nml + tau_bm = 7200., + rhbm = .7 , + do_simp = .false., + do_shallower = .true., + do_changeqref = .false., + do_envsat = .false., + do_taucape = .false., + capetaubm = 900., + tau_min = 2400./ + +&moist_conv_nml + beta = 0.0, + use_df_stuff = .true./ + + &monin_obukhov_nml + rich_crit = 2.0, + drag_min = 4.e-05 / + + + + &lscale_cond_nml + do_evap = .true., + use_df_stuff = .true. / + + &vert_diff_driver_nml + do_conserve_energy = .true., + use_virtual_temp_vert_diff = .false. / + + + + &diffusivity_nml + do_entrain = .false + use_df_stuff = .true. / + + &surface_flux_nml + use_virtual_temp = .false., + use_df_stuff = .true., + old_dtaudv = .true., + gust_const = 1.0 / + + + + &vert_turb_driver_nml + use_tau = .false., + gust_scheme = 'constant', + constant_gust = 0., + do_mellor_yamada = .false., + do_shallow_conv = .false., + use_df_stuff = .true., + do_diffusivity = .true./ + + &ocean_rough_nml + rough_scheme = 'beljaars' / + + &physics_driver_nml + do_grey_radiation = .false., + do_rrtm_radiation = .true., + do_damping = .true. / + +# domains_stack_size will vary for different model resolutions, +# domain decompositions, and number of processors used. + +&fms_nml + domains_stack_size = 600000 / + + &fms_io_nml + threading_write = 'single', + fileset_write = 'single' / + + + + diff --git a/input_fp_tf.nml b/input_fp_tf.nml new file mode 100644 index 0000000..b73b75a --- /dev/null +++ b/input_fp_tf.nml @@ -0,0 +1,220 @@ +&coupler_nml + days = 10, + dt_atmos =500, + current_date = 0001,1,1,0,0,0 + calendar = 'thirty_day' / + +# Note: damping_order = 4 specifies del 8'th diffusion + &spectral_dynamics_nml + damping_option = 'resolution_dependent', + damping_order = 4, + do_mass_correction =.true., + do_energy_correction =.true., + do_water_correction =.true., + water_correction_limit = 200.e2, + initial_sphum = 2.e-06, + use_virtual_temperature =.false., + vert_advect_uv = 'second_centered', + vert_advect_t = 'second_centered', + use_implicit = .true., + longitude_origin = 0., + robert_coeff = .03, + alpha_implicit = .5, + reference_sea_level_press=1.e5, + lon_max = 128, + lat_max = 64, + num_levels = 40, + num_fourier = 42, + num_spherical = 43, + fourier_inc = 1, + triang_trunc =.true., + topography_option = 'interpolated', + ocean_topog_smoothing = 0.995, + vert_coord_option = 'uneven_sigma', + surf_res = 0.1, + scale_heights = 7.9, + exponent = 1.4 / + + +# Empty namelist causes all values to take on default values. + + &spectral_init_cond_nml + initial_temperature = 264. / + +---------- physics namelists -------------- + + &rrtm_radiation_nml + h2o_lower_limit = 2.e-07, + co2ppmv = 390., + do_read_ozone = .true., + ozone_file = 'ozone_1990', + dt_rad_avg = 4500, + dt_rad = 4500, + lonstep = 4 / + + &astro_nml + solr_cnst = 1370. / + + &simple_surface_nml + do_qflux = .true., + surface_choice = 1, + Tm = 285., + heat_capacity = 3.e08, + land_capacity = 1.e07, + trop_capacity = 1.e08, + trop_cap_limit = 20. + const_albedo = 0.23, + albedo_choice = 7, + albedo_wdth = 5, + higher_albedo = 0.80, + albedo_cntrNH = 68., + albedo_cntrSH = 64., + lat_glacier = -70, + land_option = 'interpolated', + do_warmpool = .true., + roughness_choice = 4, + mom_roughness_land = 5.e3, + q_roughness_land = 1.e-12 / + +&qflux_nml + qflux_amp = 26., + warmpool_localization_choice = 3, + warmpool_k = 1.66666, + warmpool_amp = 18., + warmpool_width = 35., + qflux_width = 16., + warmpool_phase = 140., + warmpool_centr = 0., + gulf_k = 4.0, + gulf_amp = 70., + kuroshio_amp = 40., + trop_atlantic_amp = 50., + gulf_phase = 310., + Hawaiiextra = 30.0, + Pac_ITCZextra = -0.0, + north_sea_heat =0.0/ + + &damping_driver_nml + do_rayleigh = .false., + trayfric = -0.5, + sponge_pbottom= 50., + do_conserve_energy = .true., + do_cg_drag = .true., + do_mg_drag = .false./ + +&topography_nml + topog_file = 'INPUT/navy_topography.data.nc', + water_file = 'INPUT/navy_pctwater.data.nc' / + + + &cg_drag_nml + Bt_0 = 0.0043, + Bt_nh = 0.00, + Bt_eq = 0.0043, + Bt_sh = 0.00, + phi0n = 15., + phi0s =-15., + dphin = 10., + dphis =-10., + flag=0, + Bw = 0.4, + Bn = 0.0, + cw = 35.0, + cwtropics = 35.0, + cn = 2.0, + kelvin_kludge = 1.0, + weighttop = 0.7, + weightminus1 = 0.28, + weightminus2 = 0.02, + source_level_pressure = 315.e+02, + damp_level_pressure = 0.85e+02, + cg_drag_freq = 21600, + runML = .true., + model_dir = '/home/sjc306/hpc-work/Datawave/MiMA/src/shared/tensorflow/', + model_name = 'run_tensorflow'/ + + &moist_processes_nml + do_bm =.true., + do_bmmass =.false., + do_bmomp =.false., + do_mca =.false., + do_lsc =.true., + do_strat =.false., + do_ras =.false., + do_diag_clouds =.false., + do_rh_clouds =.false., + use_df_stuff = .true. / + + &betts_miller_nml + tau_bm = 7200., + rhbm = .7 , + do_simp = .false., + do_shallower = .true., + do_changeqref = .false., + do_envsat = .false., + do_taucape = .false., + capetaubm = 900., + tau_min = 2400./ + +&moist_conv_nml + beta = 0.0, + use_df_stuff = .true./ + + &monin_obukhov_nml + rich_crit = 2.0, + drag_min = 4.e-05 / + + + + &lscale_cond_nml + do_evap = .true., + use_df_stuff = .true. / + + &vert_diff_driver_nml + do_conserve_energy = .true., + use_virtual_temp_vert_diff = .false. / + + + + &diffusivity_nml + do_entrain = .false + use_df_stuff = .true. / + + &surface_flux_nml + use_virtual_temp = .false., + use_df_stuff = .true., + old_dtaudv = .true., + gust_const = 1.0 / + + + + &vert_turb_driver_nml + use_tau = .false., + gust_scheme = 'constant', + constant_gust = 0., + do_mellor_yamada = .false., + do_shallow_conv = .false., + use_df_stuff = .true., + do_diffusivity = .true./ + + &ocean_rough_nml + rough_scheme = 'beljaars' / + + &physics_driver_nml + do_grey_radiation = .false., + do_rrtm_radiation = .true., + do_damping = .true. / + +# domains_stack_size will vary for different model resolutions, +# domain decompositions, and number of processors used. + +&fms_nml + domains_stack_size = 600000 / + + &fms_io_nml + threading_write = 'single', + fileset_write = 'single' / + + + + diff --git a/input_pt.nml b/input_pt.nml new file mode 100644 index 0000000..92b20cd --- /dev/null +++ b/input_pt.nml @@ -0,0 +1,220 @@ +&coupler_nml + days = 10, + dt_atmos =500, + current_date = 0001,1,1,0,0,0 + calendar = 'thirty_day' / + +# Note: damping_order = 4 specifies del 8'th diffusion + &spectral_dynamics_nml + damping_option = 'resolution_dependent', + damping_order = 4, + do_mass_correction =.true., + do_energy_correction =.true., + do_water_correction =.true., + water_correction_limit = 200.e2, + initial_sphum = 2.e-06, + use_virtual_temperature =.false., + vert_advect_uv = 'second_centered', + vert_advect_t = 'second_centered', + use_implicit = .true., + longitude_origin = 0., + robert_coeff = .03, + alpha_implicit = .5, + reference_sea_level_press=1.e5, + lon_max = 128, + lat_max = 64, + num_levels = 40, + num_fourier = 42, + num_spherical = 43, + fourier_inc = 1, + triang_trunc =.true., + topography_option = 'interpolated', + ocean_topog_smoothing = 0.995, + vert_coord_option = 'uneven_sigma', + surf_res = 0.1, + scale_heights = 7.9, + exponent = 1.4 / + + +# Empty namelist causes all values to take on default values. + + &spectral_init_cond_nml + initial_temperature = 264. / + +---------- physics namelists -------------- + + &rrtm_radiation_nml + h2o_lower_limit = 2.e-07, + co2ppmv = 390., + do_read_ozone = .true., + ozone_file = 'ozone_1990', + dt_rad_avg = 4500, + dt_rad = 4500, + lonstep = 4 / + + &astro_nml + solr_cnst = 1370. / + + &simple_surface_nml + do_qflux = .true., + surface_choice = 1, + Tm = 285., + heat_capacity = 3.e08, + land_capacity = 1.e07, + trop_capacity = 1.e08, + trop_cap_limit = 20. + const_albedo = 0.23, + albedo_choice = 7, + albedo_wdth = 5, + higher_albedo = 0.80, + albedo_cntrNH = 68., + albedo_cntrSH = 64., + lat_glacier = -70, + land_option = 'interpolated', + do_warmpool = .true., + roughness_choice = 4, + mom_roughness_land = 5.e3, + q_roughness_land = 1.e-12 / + +&qflux_nml + qflux_amp = 26., + warmpool_localization_choice = 3, + warmpool_k = 1.66666, + warmpool_amp = 18., + warmpool_width = 35., + qflux_width = 16., + warmpool_phase = 140., + warmpool_centr = 0., + gulf_k = 4.0, + gulf_amp = 70., + kuroshio_amp = 40., + trop_atlantic_amp = 50., + gulf_phase = 310., + Hawaiiextra = 30.0, + Pac_ITCZextra = -0.0, + north_sea_heat =0.0/ + + &damping_driver_nml + do_rayleigh = .false., + trayfric = -0.5, + sponge_pbottom= 50., + do_conserve_energy = .true., + do_cg_drag = .true., + do_mg_drag = .false./ + +&topography_nml + topog_file = 'INPUT/navy_topography.data.nc', + water_file = 'INPUT/navy_pctwater.data.nc' / + + + &cg_drag_nml + Bt_0 = 0.0043, + Bt_nh = 0.00, + Bt_eq = 0.0043, + Bt_sh = 0.00, + phi0n = 15., + phi0s =-15., + dphin = 10., + dphis =-10., + flag=0, + Bw = 0.4, + Bn = 0.0, + cw = 35.0, + cwtropics = 35.0, + cn = 2.0, + kelvin_kludge = 1.0, + weighttop = 0.7, + weightminus1 = 0.28, + weightminus2 = 0.02, + source_level_pressure = 315.e+02, + damp_level_pressure = 0.85e+02, + cg_drag_freq = 21600, + runML = .true., + model_dir = '/home/sjc306/hpc-work/Datawave/MiMA/src/shared/pytorch/', + model_name = 'saved_model.pth'/ + + &moist_processes_nml + do_bm =.true., + do_bmmass =.false., + do_bmomp =.false., + do_mca =.false., + do_lsc =.true., + do_strat =.false., + do_ras =.false., + do_diag_clouds =.false., + do_rh_clouds =.false., + use_df_stuff = .true. / + + &betts_miller_nml + tau_bm = 7200., + rhbm = .7 , + do_simp = .false., + do_shallower = .true., + do_changeqref = .false., + do_envsat = .false., + do_taucape = .false., + capetaubm = 900., + tau_min = 2400./ + +&moist_conv_nml + beta = 0.0, + use_df_stuff = .true./ + + &monin_obukhov_nml + rich_crit = 2.0, + drag_min = 4.e-05 / + + + + &lscale_cond_nml + do_evap = .true., + use_df_stuff = .true. / + + &vert_diff_driver_nml + do_conserve_energy = .true., + use_virtual_temp_vert_diff = .false. / + + + + &diffusivity_nml + do_entrain = .false + use_df_stuff = .true. / + + &surface_flux_nml + use_virtual_temp = .false., + use_df_stuff = .true., + old_dtaudv = .true., + gust_const = 1.0 / + + + + &vert_turb_driver_nml + use_tau = .false., + gust_scheme = 'constant', + constant_gust = 0., + do_mellor_yamada = .false., + do_shallow_conv = .false., + use_df_stuff = .true., + do_diffusivity = .true./ + + &ocean_rough_nml + rough_scheme = 'beljaars' / + + &physics_driver_nml + do_grey_radiation = .false., + do_rrtm_radiation = .true., + do_damping = .true. / + +# domains_stack_size will vary for different model resolutions, +# domain decompositions, and number of processors used. + +&fms_nml + domains_stack_size = 600000 / + + &fms_io_nml + threading_write = 'single', + fileset_write = 'single' / + + + + diff --git a/input_tf.nml b/input_tf.nml new file mode 100644 index 0000000..c9d752b --- /dev/null +++ b/input_tf.nml @@ -0,0 +1,220 @@ +&coupler_nml + days = 10, + dt_atmos =500, + current_date = 0001,1,1,0,0,0 + calendar = 'thirty_day' / + +# Note: damping_order = 4 specifies del 8'th diffusion + &spectral_dynamics_nml + damping_option = 'resolution_dependent', + damping_order = 4, + do_mass_correction =.true., + do_energy_correction =.true., + do_water_correction =.true., + water_correction_limit = 200.e2, + initial_sphum = 2.e-06, + use_virtual_temperature =.false., + vert_advect_uv = 'second_centered', + vert_advect_t = 'second_centered', + use_implicit = .true., + longitude_origin = 0., + robert_coeff = .03, + alpha_implicit = .5, + reference_sea_level_press=1.e5, + lon_max = 128, + lat_max = 64, + num_levels = 40, + num_fourier = 42, + num_spherical = 43, + fourier_inc = 1, + triang_trunc =.true., + topography_option = 'interpolated', + ocean_topog_smoothing = 0.995, + vert_coord_option = 'uneven_sigma', + surf_res = 0.1, + scale_heights = 7.9, + exponent = 1.4 / + + +# Empty namelist causes all values to take on default values. + + &spectral_init_cond_nml + initial_temperature = 264. / + +---------- physics namelists -------------- + + &rrtm_radiation_nml + h2o_lower_limit = 2.e-07, + co2ppmv = 390., + do_read_ozone = .true., + ozone_file = 'ozone_1990', + dt_rad_avg = 4500, + dt_rad = 4500, + lonstep = 4 / + + &astro_nml + solr_cnst = 1370. / + + &simple_surface_nml + do_qflux = .true., + surface_choice = 1, + Tm = 285., + heat_capacity = 3.e08, + land_capacity = 1.e07, + trop_capacity = 1.e08, + trop_cap_limit = 20. + const_albedo = 0.23, + albedo_choice = 7, + albedo_wdth = 5, + higher_albedo = 0.80, + albedo_cntrNH = 68., + albedo_cntrSH = 64., + lat_glacier = -70, + land_option = 'interpolated', + do_warmpool = .true., + roughness_choice = 4, + mom_roughness_land = 5.e3, + q_roughness_land = 1.e-12 / + +&qflux_nml + qflux_amp = 26., + warmpool_localization_choice = 3, + warmpool_k = 1.66666, + warmpool_amp = 18., + warmpool_width = 35., + qflux_width = 16., + warmpool_phase = 140., + warmpool_centr = 0., + gulf_k = 4.0, + gulf_amp = 70., + kuroshio_amp = 40., + trop_atlantic_amp = 50., + gulf_phase = 310., + Hawaiiextra = 30.0, + Pac_ITCZextra = -0.0, + north_sea_heat =0.0/ + + &damping_driver_nml + do_rayleigh = .false., + trayfric = -0.5, + sponge_pbottom= 50., + do_conserve_energy = .true., + do_cg_drag = .true., + do_mg_drag = .false./ + +&topography_nml + topog_file = 'INPUT/navy_topography.data.nc', + water_file = 'INPUT/navy_pctwater.data.nc' / + + + &cg_drag_nml + Bt_0 = 0.0043, + Bt_nh = 0.00, + Bt_eq = 0.0043, + Bt_sh = 0.00, + phi0n = 15., + phi0s =-15., + dphin = 10., + dphis =-10., + flag=0, + Bw = 0.4, + Bn = 0.0, + cw = 35.0, + cwtropics = 35.0, + cn = 2.0, + kelvin_kludge = 1.0, + weighttop = 0.7, + weightminus1 = 0.28, + weightminus2 = 0.02, + source_level_pressure = 315.e+02, + damp_level_pressure = 0.85e+02, + cg_drag_freq = 21600, + runML = .true., + model_dir = '/home/sjc306/hpc-work/Datawave/MiMA/src/shared/tensorflow/', + model_name = 'saved_model'/ + + &moist_processes_nml + do_bm =.true., + do_bmmass =.false., + do_bmomp =.false., + do_mca =.false., + do_lsc =.true., + do_strat =.false., + do_ras =.false., + do_diag_clouds =.false., + do_rh_clouds =.false., + use_df_stuff = .true. / + + &betts_miller_nml + tau_bm = 7200., + rhbm = .7 , + do_simp = .false., + do_shallower = .true., + do_changeqref = .false., + do_envsat = .false., + do_taucape = .false., + capetaubm = 900., + tau_min = 2400./ + +&moist_conv_nml + beta = 0.0, + use_df_stuff = .true./ + + &monin_obukhov_nml + rich_crit = 2.0, + drag_min = 4.e-05 / + + + + &lscale_cond_nml + do_evap = .true., + use_df_stuff = .true. / + + &vert_diff_driver_nml + do_conserve_energy = .true., + use_virtual_temp_vert_diff = .false. / + + + + &diffusivity_nml + do_entrain = .false + use_df_stuff = .true. / + + &surface_flux_nml + use_virtual_temp = .false., + use_df_stuff = .true., + old_dtaudv = .true., + gust_const = 1.0 / + + + + &vert_turb_driver_nml + use_tau = .false., + gust_scheme = 'constant', + constant_gust = 0., + do_mellor_yamada = .false., + do_shallow_conv = .false., + use_df_stuff = .true., + do_diffusivity = .true./ + + &ocean_rough_nml + rough_scheme = 'beljaars' / + + &physics_driver_nml + do_grey_radiation = .false., + do_rrtm_radiation = .true., + do_damping = .true. / + +# domains_stack_size will vary for different model resolutions, +# domain decompositions, and number of processors used. + +&fms_nml + domains_stack_size = 600000 / + + &fms_io_nml + threading_write = 'single', + fileset_write = 'single' / + + + + diff --git a/src/atmos_coupled/CMakeLists.txt b/src/atmos_coupled/CMakeLists.txt new file mode 100644 index 0000000..8329afa --- /dev/null +++ b/src/atmos_coupled/CMakeLists.txt @@ -0,0 +1,6 @@ +set ( ATMOS_COUPLED_SOURCES +atmos_model.f90 +#atmos_model.html +) + +target_sources( mima.x PRIVATE ${ATMOS_COUPLED_SOURCES} ) diff --git a/src/atmos_param/CMakeLists.txt b/src/atmos_param/CMakeLists.txt new file mode 100644 index 0000000..96e666d --- /dev/null +++ b/src/atmos_param/CMakeLists.txt @@ -0,0 +1,182 @@ +set ( ATMOS_PARAM_SOURCES +cloud_zonal/null/cloud_zonal.f90 +vert_diff_driver/vert_diff_driver.f90 +moist_conv/moist_conv.f90 +# moist_conv/null/moist_conv.f90 +moist_processes/moist_processes.f90 +damping_driver/damping_driver.f90 +cloud_rad/cloud_rad.f90 +cg_drag/cg_drag.f90 +ras/ras.f90 +diag_integral/diag_integral.f90 +edt/edt.f90 +# edt/null/edt.f90 +# my25_turb/null/my25_turb.f90 +my25_turb/my25_turb.f90 +diag_cloud/null/diag_cloud.f90 +vert_diff/vert_diff.f90 +# shallow_conv/shallow_conv.f90 +shallow_conv/null/shallow_conv.f90 +grey_radiation/grey_radiation.f90 +vert_turb_driver/vert_turb_driver.f90 +qflux/qflux.f90 +# donner_deep/null/donner_deep.f90 +donner_deep/donner_deep.f90 +entrain/entrain.f90 +cu_mo_trans/cu_mo_trans.f90 +mg_drag/mg_drag.f90 +cloud_generator/betaDistribution.f90 +cloud_generator/null/cloud_generator.f90 +topo_drag/null/topo_drag.f90 +# diffusivity/null/diffusivity.f90 +diffusivity/diffusivity.f90 +physics_driver/physics_driver.f90 +rh_clouds/null/rh_clouds.f90 +betts_miller/bm_omp.f90 +betts_miller/betts_miller.f90 +betts_miller/bm_massflux.f90 +monin_obukhov/monin_obukhov.f90 +lscale_cond/lscale_cond.f90 +# lscale_cond/null/lscale_cond.f90 +radiation_driver/radiation_driver.f90 +local_heating/local_heating.f90 +astronomy/astronomy.f90 +sea_esf_rad/sea_esf_rad.f90 +sea_esf_rad/rad_output_file.f90 +sea_esf_rad/microphys_rad.f90 +sea_esf_rad/microphys_cloud.f90 +# FIXME this is the overlay thing, this file is replaced by the above e.g. sea_esf_rad/null/specified_clouds_W.f90 +# sea_esf_rad/standalone_clouds.f90 +sea_esf_rad/bulkphys_rad.f90 +sea_esf_rad/longwave_fluxes.f90 +sea_esf_rad/optical_path.f90 +sea_esf_rad/aerosolrad_package.f90 +sea_esf_rad/longwave_clouds.f90 +sea_esf_rad/gas_tf.f90 +sea_esf_rad/sealw99.f90 +sea_esf_rad/rh_based_clouds.f90 +sea_esf_rad/diag_clouds_W.f90 +sea_esf_rad/isccp_clouds.f90 +# sea_esf_rad/specified_clouds_W.f90 +sea_esf_rad/donner_deep_clouds_W.f90 +sea_esf_rad/radiation_diag.f90 +sea_esf_rad/longwave_tables.f90 +sea_esf_rad/rad_utilities.f90 +sea_esf_rad/lhsw_driver.f90 +sea_esf_rad/ozone.f90 +sea_esf_rad/cloudrad_diagnostics.f90 +sea_esf_rad/radiative_gases.f90 +sea_esf_rad/esfsw_driver.f90 +sea_esf_rad/zetac_clouds_W.f90 +sea_esf_rad/longwave_params.f90 +sea_esf_rad/aerosol.F90 +# sea_esf_rad/original_fms_rad.f90 +sea_esf_rad/cloud_spec.f90 +sea_esf_rad/null/standalone_clouds.f90 +# sea_esf_rad/null/bulkphys_rad.f90 +# sea_esf_rad/null/rh_based_clouds.f90 +# sea_esf_rad/null/diag_clouds_W.f90 +# FIXME this is the overlay thing, this file is replaced by the above e.g. sea_esf_rad/null/specified_clouds_W.f90 +sea_esf_rad/null/specified_clouds_W.f90 +# sea_esf_rad/null/donner_deep_clouds_W.f90 +# sea_esf_rad/null/lhsw_driver.f90 +sea_esf_rad/null/original_fms_rad.f90 +# sea_esf_rad/null/mgrp_prscr_clds.f90 +sea_esf_rad/shortwave_driver.f90 +sea_esf_rad/strat_clouds_W.f90 +sea_esf_rad/lw_gases_stdtf.f90 +sea_esf_rad/mgrp_prscr_clds.f90 +sea_esf_rad/longwave_driver.f90 +sea_esf_rad/cloudrad_package.f90 +sea_esf_rad/esfsw_parameters.f90 +stable_bl_turb/stable_bl_turb.f90 +dry_adj/dry_adj.f90 +# dry_adj/null/dry_adj.f90 +rrtm_radiation/astro.f90 +rrtm_radiation/rrtmg_sw/gcm_model/src/mcica_subcol_gen_sw.f90 +rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.f90 +rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_cldprop.f90 +# rrtm_radiation/rrtmg_sw/gcm_model/src/mcica_random_numbers.f90 +rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.nomcica.f90 +rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvrt.f90 +# rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.f90 +rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_cldprmc.f90 +# rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_read_nc.f90 +rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_setcoef.f90 +rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_init.f90 +rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_reftra.f90 +rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_vrtqdr.f90 +rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_taumol.f90 +# Long Time to Compile so special flags in main CMakeLists +rrtm_radiation/rrtmg_sw/gcm_model/src/rrtmg_sw_k_g.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg22.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg20.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg26.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg23.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_vsn.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg24.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_ref.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg19.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_cld.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg25.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg28.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_wvn.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg21.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg27.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_con.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/parrrsw.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_aer.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg16.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_ncpar.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_tbl.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg17.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg18.f90 +# rrtm_radiation/rrtmg_sw/gcm_model/modules/parkind.f90 +rrtm_radiation/rrtmg_sw/gcm_model/modules/rrsw_kg29.f90 +rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_cldprmc.f90 +rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_setcoef.f90 +rrtm_radiation/rrtmg_lw/gcm_model/src/mcica_subcol_gen_lw.f90 +rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_init.f90 +# Not required if rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_k_g.f90 used +# rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_read_nc.f90 +rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_taumol.f90 +rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_rtrnmc.f90 +# Long Time to Compile so special flags in main CMakeLists +rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_k_g.f90 +rrtm_radiation/rrtmg_lw/gcm_model/src/mcica_random_numbers.f90 +rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_cldprop.f90 +rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_rtrn.f90 +# rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_rad.f90 +rrtm_radiation/rrtm_radiation.f90 +rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_rtrnmr.f90 +rrtm_radiation/rrtmg_lw/gcm_model/src/rrtmg_lw_rad.nomcica.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg03.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_con.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg14.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg11.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg04.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_wvn.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_ncpar.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_vsn.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg15.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/parrrtm.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg05.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_ref.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg16.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg09.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg06.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg10.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg12.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg01.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/parkind.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg08.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_cld.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg13.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_tbl.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg02.f90 +rrtm_radiation/rrtmg_lw/gcm_model/modules/rrlw_kg07.f90 +diag_cloud_rad/null/diag_cloud_rad.f90 +strat_cloud/strat_cloud.f90 +) + +target_sources ( mima.x PRIVATE ${ATMOS_PARAM_SOURCES} ) diff --git a/src/atmos_param/cg_drag/cg_drag.f90 b/src/atmos_param/cg_drag/cg_drag.f90 index 66fc6b6..052cb3a 100644 --- a/src/atmos_param/cg_drag/cg_drag.f90 +++ b/src/atmos_param/cg_drag/cg_drag.f90 @@ -16,6 +16,10 @@ module cg_drag_mod use constants_mod, only: constants_init, PI, RDGAS, GRAV, CP_AIR, & SECONDS_PER_DAY +use mpp_mod, only: mpp_clock_id, mpp_clock_begin, mpp_clock_end + +use cg_drag_ML_mod, only: cg_drag_ML_init, cg_drag_ML_end, cg_drag_ML + #ifdef COL_DIAG use column_diagnostics_mod, only: column_diagnostics_init, & initialize_diagnostic_columns, & @@ -87,7 +91,9 @@ module cg_drag_mod ! wave source level at the equator ! [ Pa ] real :: damp_level_pressure=0.8e+02 - ! added by cig, feb 27, 2017. any waves reaching the top level will be deposited down to this level + ! added by cig, feb 27, 2017. any waves + ! reaching the top level will be + ! deposited down to this level integer :: nk=1 ! number of wavelengths contained in ! the gravity wave spectrum real :: cmax=99.6 ! maximum phase speed in gravity wave @@ -159,6 +165,13 @@ module cg_drag_mod ! longitudes for latlon diagnostic ! columns [ degrees, 0. -> 360. ] +logical :: runML=.false. + ! are we using ML to calculate the drag? + +character(len=1024) :: model_dir="undefined/" + ! Full filepath to directory contaioning ML model +character(len=1024) :: model_name="undefined" + ! Filename of ML model/name of script to run namelist / cg_drag_nml / & cg_drag_freq, cg_drag_offset, & @@ -170,7 +183,9 @@ module cg_drag_mod i_coords_gl, j_coords_gl, & lat_coords_gl, lon_coords_gl, & phi0n,phi0s,dphin,dphis, Bw, Bn, cw, cwtropics, cn, flag, & - weightminus2, weightminus1, weighttop,kelvin_kludge + weightminus2, weightminus1, weighttop,kelvin_kludge,& + ! Added for ML + runML, model_dir, model_name !-------------------------------------------------------------------- @@ -216,7 +231,7 @@ module cg_drag_mod integer :: klevel_of_source, klevel_of_damp ! k index of the gravity wave source level at ! the equator in a standard atmosphere - ! also k index of level up to where mesosphere drag is dumped (cig, feb 27 2017) + ! also k index of level up to where mesosphere drag is dumped (cig, feb 27 2017) !--------------------------------------------------------------------- @@ -388,7 +403,7 @@ subroutine cg_drag_init (lonb, latb, pref, Time, axes) ! ied as the source location via namelist input. !-------------------------------------------------------------------- do k=1,kmax - if (pref(k) < damp_level_pressure) then + if (pref(k) < damp_level_pressure) then klevel_of_damp = k endif if (pref(k) > source_level_pressure) then @@ -405,23 +420,23 @@ subroutine cg_drag_init (lonb, latb, pref, Time, axes) lat(i,j)= 0.5*( latb(j+1)+latb(j) ) source_level(i,j) = (kmax + 1) - ((kmax + 1 - & klevel_of_source)*cos(lat(i,j)) + 0.5) - - damp_level(i,j) = klevel_of_damp !cig - thislatdeg=lat(i,j)*pifinv + + damp_level(i,j) = klevel_of_damp !cig + thislatdeg=lat(i,j)*pifinv !code added by ipw - nov 23, 2016 - if (thislatdeg > phi0n) then + if (thislatdeg > phi0n) then + source_amp(i,j) = Bt_0 + Bt_nh*0.5*(1.+tanh((thislatdeg-phi0n)/dphin))+ & + Bt_sh*0.5*(1.+tanh((thislatdeg-phi0s)/dphis)); + elseif (thislatdeg < phi0s) then source_amp(i,j) = Bt_0 + Bt_nh*0.5*(1.+tanh((thislatdeg-phi0n)/dphin))+ & Bt_sh*0.5*(1.+tanh((thislatdeg-phi0s)/dphis)); - elseif (thislatdeg < phi0s) then - source_amp(i,j) = Bt_0 + Bt_nh*0.5*(1.+tanh((thislatdeg-phi0n)/dphin))+ & - Bt_sh*0.5*(1.+tanh((thislatdeg-phi0s)/dphis)); - elseif ((thislatdeg <= dphin) .and. (thislatdeg >= dphis)) then - source_amp(i,j) = Bt_eq - elseif ((thislatdeg <= phi0n) .and. (thislatdeg > dphin)) then - source_amp(i,j) = Bt_0 + (Bt_eq-Bt_0)/(phi0n-dphin)*(phi0n-thislatdeg) - elseif ((thislatdeg < dphis) .and. (thislatdeg >= phi0s)) then - source_amp(i,j) = Bt_0 + (Bt_eq-Bt_0)/(phi0s-dphis)*(phi0s-thislatdeg) - endif + elseif ((thislatdeg <= dphin) .and. (thislatdeg >= dphis)) then + source_amp(i,j) = Bt_eq + elseif ((thislatdeg <= phi0n) .and. (thislatdeg > dphin)) then + source_amp(i,j) = Bt_0 + (Bt_eq-Bt_0)/(phi0n-dphin)*(phi0n-thislatdeg) + elseif ((thislatdeg < dphis) .and. (thislatdeg >= phi0s)) then + source_amp(i,j) = Bt_0 + (Bt_eq-Bt_0)/(phi0s-dphis)*(phi0s-thislatdeg) + endif ! source_amp(i,j) = Bt_0 + & ! Bt_nh*0.5*(1.+tanh((lat(i,j)/pif-phi0n)/dphin)) + & @@ -570,7 +585,16 @@ subroutine cg_drag_init (lonb, latb, pref, Time, axes) endif !!$ endif !!$ vers = restart_versions(size(restart_versions(:))) -!!$ old_time_step = cgdrag_alarm +!!$ old_time_step = cgdrag_alarm + + +!--------------------------------------------------------------------- +! initialize the ML functionalities +!--------------------------------------------------------------------- + if (runML) then + call cg_drag_ML_init(model_dir, model_name) + endif + !--------------------------------------------------------------------- ! mark the module as initialized. !--------------------------------------------------------------------- @@ -617,7 +641,7 @@ end subroutine cg_drag_endts !#################################################################### -subroutine cg_drag_calc (is, js, lat, pfull, zfull, temp, uuu, vvv, & +subroutine cg_drag_calc (is, js, lat, pfull, zfull, psfc, temp, uuu, vvv, & Time, delt, gwfcng_x, gwfcng_y) !-------------------------------------------------------------------- ! cg_drag_calc defines the arrays needed to calculate the convective @@ -629,12 +653,15 @@ subroutine cg_drag_calc (is, js, lat, pfull, zfull, temp, uuu, vvv, & !--------------------------------------------------------------------- integer, intent(in) :: is, js -real, dimension(:,:), intent(in) :: lat +real, dimension(:,:), intent(in) :: lat, psfc real, dimension(:,:,:), intent(in) :: pfull, zfull, temp, uuu, vvv type(time_type), intent(in) :: Time real , intent(in) :: delt real, dimension(:,:,:), intent(out) :: gwfcng_x, gwfcng_y +! FIXME +real, dimension(:,:,:), allocatable :: gwfcng_x_AD, gwfcng_y_AD + !------------------------------------------------------------------- ! intent(in) variables: ! @@ -672,7 +699,7 @@ subroutine cg_drag_calc (is, js, lat, pfull, zfull, temp, uuu, vvv, & integer :: iz0 logical :: used real :: bflim = 2.5E-5 - integer :: ie, je + integer :: ie, je, timer_id integer :: imax, jmax, kmax integer :: i, j, k, nn real :: pif = 3.14159265358979/180. @@ -797,22 +824,67 @@ subroutine cg_drag_calc (is, js, lat, pfull, zfull, temp, uuu, vvv, & end do !--------------------------------------------------------------------- -! pass the vertically-extended input arrays to gwfc. gwfc will cal- -! culate the gravity-wave forcing and, if desired, an effective eddy -! diffusion coefficient at each level above the source level. output -! is returned in the vertically-extended arrays gwfcng and ked_gwfc. -! upon return move the output fields into model-sized arrays. -!--------------------------------------------------------------------- - call gwfc (is, ie, js, je, damp_level, source_level, source_amp, lat, & - zden, zu, zbf,zzchm, gwd_xtnd, ked_xtnd) - - gwfcng_x (:,:,1:kmax) = gwd_xtnd(:,:,1:kmax ) - ked_gwfc_x(:,:,1:kmax) = ked_xtnd(:,:,1:kmax ) - - call gwfc (is, ie, js, je, damp_level, source_level, source_amp, lat, & - zden, zv, zbf,zzchm, gwd_ytnd, ked_ytnd) - gwfcng_y (:,:,1:kmax) = gwd_ytnd(:,:,1:kmax ) - ked_gwfc_y(:,:,1:kmax) = ked_ytnd(:,:,1:kmax ) +! calculate the gravity-wave forcing and, if desired, an effective +! eddy diffusion coefficient at each level above the source level. +! output is returned in the vertically-extended arrays gwfcng and +! ked_gwfc. upon return move the output fields into model-sized +! arrays. +! there are multiple options for calculating the gravity wave forcing +! gwfcng_x, gwfcng_y: +! - AD99 Parameterisation (gwfc subroutine) +! - Wavenet ML model via: +! - forpy python coupling, +! - PyTorch TorchScript coupling, +! - Tensorflow coupling +!--------------------------------------------------------------------- + ! START OF ML COUPLING CHANGES + + timer_id = mpp_clock_id( 'cg_drag' ) + call mpp_clock_begin(timer_id) + + if (runML) then + call cg_drag_ML (uuu, vvv, psfc, lat, gwfcng_x, gwfcng_y) + else + + ! AD99 Parameterisation from original code +! allocate(gwfcng_x_AD(size(gwfcng_x, 1), size(gwfcng_x, 2), size(gwfcng_x, 3))) +! allocate(gwfcng_y_AD(size(gwfcng_y, 1), size(gwfcng_y, 2), size(gwfcng_y, 3))) + call gwfc (is, ie, js, je, damp_level, source_level, source_amp, lat, & + zden, zu, zbf,zzchm, gwd_xtnd, ked_xtnd) + !gwfcng_x (:,:,1:kmax) = gwd_xtnd(:,:,1:kmax ) + gwfcng_x (:,:,1:kmax) = gwd_xtnd(:,:,1:kmax ) + + call gwfc (is, ie, js, je, damp_level, source_level, source_amp, lat, & + zden, zv, zbf,zzchm, gwd_ytnd, ked_ytnd) + !gwfcng_y (:,:,1:kmax) = gwd_ytnd(:,:,1:kmax ) + gwfcng_y (:,:,1:kmax) = gwd_ytnd(:,:,1:kmax ) + + + ! TODO ked is only ever used as a diagnostic to be written out - we do not need to calculate it! + ! ked_gwfc_x(:,:,1:kmax) = ked_xtnd(:,:,1:kmax ) + ! ked_gwfc_y(:,:,1:kmax) = ked_ytnd(:,:,1:kmax ) + + endif +! SJC Debug printing for ML GW computation +! if (mpp_pe() == mpp_root_pe()) then +! write(*,*)'uuu (1,1)' +! write(*,*) uuu(1,1,1:kmax) +! write(*,*)'psfc (1,1)' +! write(*,*) psfc(1,1) +! write(*,*)'lat (1,1)' +! write(*,*) lat(1,1) +! write(*,*)'AD output (1,1)' +! write(*,*) gwfcng_x_AD(1,1,1:kmax) +! write(*,*)'ML output (1,1)' +! write(*,*) gwfcng_x(1,1,1:kmax) +! endif +! stop +! deallocate(gwfcng_x_AD) +! deallocate(gwfcng_y_AD) + + call mpp_clock_end(timer_id) + + ! END OF ML COUPLING CHANGES !-------------------------------------------------------------------- ! store the gravity wave forcing into a processor-global array. @@ -943,6 +1015,13 @@ subroutine cg_drag_end endif #endif +!--------------------------------------------------------------------- +! Clean up any ML detritus. +!--------------------------------------------------------------------- + if (runML) then + call cg_drag_ML_end + endif + !--------------------------------------------------------------------- ! mark the module as uninitialized. !--------------------------------------------------------------------- diff --git a/src/atmos_param/cg_drag/forpy.f90 b/src/atmos_param/cg_drag/forpy.f90 new file mode 100644 index 0000000..e2f27d9 --- /dev/null +++ b/src/atmos_param/cg_drag/forpy.f90 @@ -0,0 +1,264 @@ +module cg_drag_ML_mod + +use constants_mod, only: RADIAN +use fms_mod, only: error_mesg, FATAL + +! Import forpy module for interfacing +use forpy_mod, only: import_py, module_py, call_py, object, ndarray, & + forpy_initialize, forpy_finalize, tuple, tuple_create, & + ndarray_create, cast, print_py, dict, dict_create, err_print, & + call_py_noret, list, get_sys_path, ndarray_create_nocopy, & + ndarray_create_empty, ndarray_create_zeros, str, str_create + +!------------------------------------------------------------------- + +implicit none +private + +public cg_drag_ML_init, cg_drag_ML_end, cg_drag_ML + +!-------------------------------------------------------------------- +! data used in this module to bind to forpy +! +!-------------------------------------------------------------------- +! run_emulator python module +! paths python list of strings with system paths +! model python 'object' that will contain the model +! args python tuple that will contain the model inputs +! py_pypath python string +! +!-------------------------------------------------------------------- + +integer :: ie +type(module_py) :: run_emulator +type(list) :: paths +type(object) :: model +type(tuple) :: args +type(str) :: py_model_dir + + +!-------------------------------------------------------------------- +!-------------------------------------------------------------------- + +contains + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! PUBLIC SUBROUTINES +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +!#################################################################### + +subroutine cg_drag_ML_init(model_dir, model_name) + + !----------------------------------------------------------------- + ! cg_drag_ML_init is called from cg_drag_init and initialises + ! anything required for the ML calculation of cg_drag such as + ! an ML model + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! intent(in) variables: + ! + ! model_path full filepath to the model + ! + !----------------------------------------------------------------- + character(len=1024), intent(in) :: model_dir + character(len=1024), intent(in) :: model_name + + !----------------------------------------------------------------- + + ! Initialise the ML model to be used + ie = forpy_initialize() + + ! Add the directory containing forpy related scripts and data to sys.path + ! This does not appear to work? + ! export PYTHONPATH=model_dir in the job environment. + ie = str_create(py_model_dir, trim(model_dir)) + ie = get_sys_path(paths) + ie = paths%append(py_model_dir) + + ! import python modules to `run_emulator` + ! Note, this will need to be able to load its dependencies + ! such as `torch`, so you will probably need a venv. + ie = import_py(run_emulator, trim(model_name)) + if (ie .ne. 0) then + call err_print + call error_mesg('cg_drag', 'forpy model not loaded', FATAL) + end if + + ! call initialize function from `run_emulator` python module + ! loads a trained model to `model` + ie = call_py(model, run_emulator, "initialize") + if (ie .ne. 0) then + call err_print + call error_mesg('cg_drag', 'call to `initialize` failed', FATAL) + end if + +end subroutine cg_drag_ML_init + + +!#################################################################### + +subroutine cg_drag_ML_end + + !----------------------------------------------------------------- + ! cg_drag_ML_end is called from cg_drag_end and is a destructor + ! for anything used in the ML part of calculating cg_drag such + ! as an ML model. + ! + !----------------------------------------------------------------- + + ! destroy the forpy objects + ! + ! according to forpy no destroy nethod for strings such as + ! py_model_dir. Because they are just C under the hood? + call paths%destroy + call run_emulator%destroy + call model%destroy + + call forpy_finalize + +end subroutine cg_drag_ML_end + + +!#################################################################### + +subroutine cg_drag_ML(uuu, vvv, psfc, lat, gwfcng_x, gwfcng_y) + + !----------------------------------------------------------------- + ! cg_drag_ML returns the x and y gravity wave drag forcing + ! terms following calculation using an external neural net. + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! intent(in) variables: + ! + ! uuu,vvv arrays of model u and v wind + ! psfc array of model surface pressure + ! lat array of model latitudes at cell boundaries [radians] + ! + ! intent(out) variables: + ! + ! gwfcng_x time tendency for u eqn due to gravity-wave forcing + ! [ m/s^2 ] + ! gwfcng_y time tendency for v eqn due to gravity-wave forcing + ! [ m/s^2 ] + ! + !----------------------------------------------------------------- + + real, dimension(:,:,:), intent(in) :: uuu, vvv + real, dimension(:,:), intent(in) :: lat, psfc + + real, dimension(:,:,:), intent(out) :: gwfcng_x, gwfcng_y + + !----------------------------------------------------------------- + + !------------------------------------------------------------------- + ! local variables: + ! + ! dtdz temperature lapse rate [ deg K/m ] + ! + !--------------------------------------------------------------------- + + real, dimension(:,:), allocatable, asynchronous :: uuu_flattened, vvv_flattened + real, dimension(:,:), allocatable, asynchronous :: lat_reshaped, psfc_reshaped + real, dimension(:,:), allocatable, asynchronous :: gwfcng_x_flattened, gwfcng_y_flattened + + integer :: imax, jmax, kmax, j + + ! forpy variables + type(ndarray) :: uuu_nd, vvv_nd, psfc_nd, lat_nd, gwfcng_x_nd, gwfcng_y_nd + type(tuple) :: args + + !---------------------------------------------------------------- + + ! reshape tensors as required + imax = size(uuu, 1) + jmax = size(uuu, 2) + kmax = size(uuu, 3) + + ! flatten data (nlat, nlon, n) --> (nlat*nlon, n) + allocate( uuu_flattened(imax*jmax, kmax) ) + allocate( vvv_flattened(imax*jmax, kmax) ) + allocate( lat_reshaped(imax*jmax, 1) ) + allocate( psfc_reshaped(imax*jmax, 1) ) + allocate( gwfcng_x_flattened(imax*jmax, kmax) ) + allocate( gwfcng_y_flattened(imax*jmax, kmax) ) + + do j=1,jmax + uuu_flattened((j-1)*imax+1:j*imax,:) = uuu(:,j,:) + vvv_flattened((j-1)*imax+1:j*imax,:) = vvv(:,j,:) + lat_reshaped((j-1)*imax+1:j*imax, 1) = lat(:,j)*RADIAN + psfc_reshaped((j-1)*imax+1:j*imax, 1) = psfc(:,j) + end do + + ! creates numpy arrays + ie = ndarray_create_nocopy(uuu_nd, uuu_flattened) + ie = ndarray_create_nocopy(vvv_nd, vvv_flattened) + ie = ndarray_create_nocopy(lat_nd, lat_reshaped) + ie = ndarray_create_nocopy(psfc_nd, psfc_reshaped) + ie = ndarray_create_nocopy(gwfcng_x_nd, gwfcng_x_flattened) + ie = ndarray_create_nocopy(gwfcng_y_nd, gwfcng_y_flattened) + + ! create model input args as tuple + ie = tuple_create(args,6) + ie = args%setitem(0,model) + ie = args%setitem(2,lat_nd) + ie = args%setitem(3,psfc_nd) + ie = args%setitem(5,jmax) + + ! Zonal + ie = args%setitem(1,uuu_nd) + ie = args%setitem(4,gwfcng_x_nd) + ! Run model and Infer + ie = call_py_noret(run_emulator, "compute_reshape_drag", args) + if (ie .ne. 0) then + call err_print + call error_mesg('cg_drag_ML', 'inference x call failed', FATAL) + end if + + ! Meridional + ie = args%setitem(1,vvv_nd) + ie = args%setitem(4,gwfcng_y_nd) + ! Run model and Infer + ie = call_py_noret(run_emulator, "compute_reshape_drag", args) + if (ie .ne. 0) then + call err_print + call error_mesg('cg_drag_ML', 'inference y call failed', FATAL) + end if + + + ! Reshape, and assign to gwfcng + do j=1,jmax + gwfcng_x(:,j,:) = gwfcng_x_flattened((j-1)*imax+1:j*imax,:) + gwfcng_y(:,j,:) = gwfcng_y_flattened((j-1)*imax+1:j*imax,:) + end do + + ! Cleanup + call uuu_nd%destroy + call vvv_nd%destroy + call psfc_nd%destroy + call lat_nd%destroy + call gwfcng_x_nd%destroy + call gwfcng_y_nd%destroy + call args%destroy + + deallocate( uuu_flattened ) + deallocate( vvv_flattened ) + deallocate( lat_reshaped ) + deallocate( psfc_reshaped ) + deallocate( gwfcng_x_flattened ) + deallocate( gwfcng_y_flattened ) + + +end subroutine cg_drag_ML + + +!#################################################################### + +end module cg_drag_ML_mod diff --git a/src/atmos_param/cg_drag/null.f90 b/src/atmos_param/cg_drag/null.f90 new file mode 100644 index 0000000..9818cbc --- /dev/null +++ b/src/atmos_param/cg_drag/null.f90 @@ -0,0 +1,33 @@ + !----------------------------------------------------------------- + ! This module was auto-generated by process_model, + ! and then edited to match the signatures required. + ! + !----------------------------------------------------------------- + +module cg_drag_ML_mod + + + implicit none + + public cg_drag_ML_init, & + cg_drag_ML, & + cg_drag_ML_end + + contains + + subroutine cg_drag_ML_init(model_dir, model_name) + ! Parameters + character(*) :: model_dir, model_name + end subroutine cg_drag_ML_init + + subroutine cg_drag_ML(uuu, vvv, psfc, lat, gwfcng_x, gwfcng_y) + real, dimension(:,:,:), intent(in) :: uuu, vvv + real, dimension(:,:), intent(in) :: lat, psfc + + real, dimension(:,:,:), intent(out), target :: gwfcng_x, gwfcng_y + end subroutine cg_drag_ML + + subroutine cg_drag_ML_end() + end subroutine cg_drag_ML_end + +end module cg_drag_ML_mod diff --git a/src/atmos_param/cg_drag/pytorch.f90 b/src/atmos_param/cg_drag/pytorch.f90 new file mode 100644 index 0000000..7dd1fa1 --- /dev/null +++ b/src/atmos_param/cg_drag/pytorch.f90 @@ -0,0 +1,220 @@ +module cg_drag_ML_mod + +use constants_mod, only: RADIAN + +! #ML +! Imports primitives used to interface with C +use, intrinsic :: iso_c_binding, only: c_int64_t, c_float, c_char, c_null_char, c_ptr, c_loc +! Import library for interfacing with PyTorch +use ftorch + +!------------------------------------------------------------------- + +implicit none +private + +public cg_drag_ML_init, cg_drag_ML_end, cg_drag_ML + +!-------------------------------------------------------------------- +! data used in this module to bind to FTorch +! +!-------------------------------------------------------------------- +! model ML model type bound to python +! +!-------------------------------------------------------------------- + +type(torch_module) :: model + + +!-------------------------------------------------------------------- +!-------------------------------------------------------------------- + +contains + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! PUBLIC SUBROUTINES +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +!#################################################################### + +subroutine cg_drag_ML_init(model_dir, model_name) + + !----------------------------------------------------------------- + ! cg_drag_ML_init is called from cg_drag_init and initialises + ! anything required for the ML calculation of cg_drag such as + ! an ML model + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! intent(in) variables: + ! + ! model_dir full filepath to the model directory + ! model_name filename of the TorchScript model + ! + !----------------------------------------------------------------- + character(len=1024), intent(in) :: model_dir + character(len=1024), intent(in) :: model_name + + !----------------------------------------------------------------- + + ! Initialise the ML model to be used + model = torch_module_load(trim(model_dir)//trim(model_name)//c_null_char) + +end subroutine cg_drag_ML_init + + +!#################################################################### + +subroutine cg_drag_ML_end + + !----------------------------------------------------------------- + ! cg_drag_ML_end is called from cg_drag_end and is a destructor + ! for anything used in the ML part of calculating cg_drag such + ! as an ML model. + ! + !----------------------------------------------------------------- + + ! destroy the model + call torch_module_delete(model) + +end subroutine cg_drag_ML_end + + +!#################################################################### + +subroutine cg_drag_ML(uuu, vvv, psfc, lat, gwfcng_x, gwfcng_y) + + !----------------------------------------------------------------- + ! cg_drag_ML returns the x and y gravity wave drag forcing + ! terms following calculation using an external neural net. + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! intent(in) variables: + ! + ! is,js starting subdomain i,j indices of data in + ! the physics_window being integrated + ! uuu,vvv arrays of model u and v wind + ! psfc array of model surface pressure + ! lat array of model latitudes at cell boundaries [radians] + ! + ! intent(out) variables: + ! + ! gwfcng_x time tendency for u eqn due to gravity-wave forcing + ! [ m/s^2 ] + ! gwfcng_y time tendency for v eqn due to gravity-wave forcing + ! [ m/s^2 ] + ! + !----------------------------------------------------------------- + + real, dimension(:,:,:), intent(in) :: uuu, vvv + real, dimension(:,:), intent(in) :: lat, psfc + + real, dimension(:,:,:), intent(out), target :: gwfcng_x, gwfcng_y + + !----------------------------------------------------------------- + + !------------------------------------------------------------------- + ! local variables: + ! + ! dtdz temperature lapse rate [ deg K/m ] + ! + !--------------------------------------------------------------------- + + real, dimension(:,:), allocatable, target :: uuu_reshaped, vvv_reshaped + real, dimension(:,:), allocatable, target :: lat_reshaped, psfc_reshaped + real, dimension(:,:), allocatable, target :: gwfcng_x_reshaped, gwfcng_y_reshaped + + integer :: imax, jmax, kmax, j, k + + integer(c_int), parameter :: dims_2D = 2 + integer(c_int64_t) :: shape_2D(dims_2D) + integer(c_int), parameter :: dims_1D = 2 + integer(c_int64_t) :: shape_1D(dims_1D) + integer(c_int), parameter :: dims_out = 2 + integer(c_int64_t) :: shape_out(dims_out) + + ! Set up types of input and output data and the interface with C + type(torch_tensor) :: gwfcng_x_tensor, gwfcng_y_tensor + integer(c_int), parameter :: n_inputs = 3 + type(torch_tensor), dimension(n_inputs), target :: model_input_arr + + !---------------------------------------------------------------- + + ! reshape tensors as required + imax = size(uuu, 1) + jmax = size(uuu, 2) + kmax = size(uuu, 3) + + ! Note that the '1D' tensor has 2 dimensions, one of which is size 1 + shape_2D = (/ imax*jmax, kmax /) + shape_1D = (/ imax*jmax, 1 /) + shape_out = (/ imax*jmax, kmax /) + + ! flatten data (nlat, nlon, n) --> (nlat*nlon, n) + allocate( uuu_reshaped(kmax, imax*jmax) ) + allocate( vvv_reshaped(kmax, imax*jmax) ) + allocate( lat_reshaped(1, imax*jmax) ) + allocate( psfc_reshaped(1, imax*jmax) ) + allocate( gwfcng_x_reshaped(kmax, imax*jmax) ) + allocate( gwfcng_y_reshaped(kmax, imax*jmax) ) + + do j=1,jmax + do k=1, kmax + uuu_reshaped(k, (j-1)*imax+1:j*imax) = uuu(:,j,k) + vvv_reshaped(k, (j-1)*imax+1:j*imax) = vvv(:,j,k) + end do + lat_reshaped(1, (j-1)*imax+1:j*imax) = lat(:,j)*RADIAN + psfc_reshaped(1, (j-1)*imax+1:j*imax) = psfc(:,j) + end do + + ! Create input/output tensors from the above arrays + model_input_arr(3) = torch_tensor_from_blob(c_loc(lat_reshaped), dims_1D, shape_1D, torch_kFloat64, torch_kCPU) + model_input_arr(2) = torch_tensor_from_blob(c_loc(psfc_reshaped), dims_1D, shape_1D, torch_kFloat64, torch_kCPU) + + ! Zonal + model_input_arr(1) = torch_tensor_from_blob(c_loc(uuu_reshaped), dims_2D, shape_2D, torch_kFloat64, torch_kCPU) + gwfcng_x_tensor = torch_tensor_from_blob(c_loc(gwfcng_x_reshaped), dims_out, shape_out, torch_kFloat64, torch_kCPU) + ! Run model and Infer + call torch_module_forward(model, model_input_arr, n_inputs, gwfcng_x_tensor) + + ! Meridional + model_input_arr(1) = torch_tensor_from_blob(c_loc(vvv_reshaped), dims_2D, shape_2D, torch_kFloat64, torch_kCPU) + gwfcng_y_tensor = torch_tensor_from_blob(c_loc(gwfcng_y_reshaped), dims_out, shape_out, torch_kFloat64, torch_kCPU) + ! Run model and Infer + call torch_module_forward(model, model_input_arr, n_inputs, gwfcng_y_tensor) + + + ! Convert back into fortran types, reshape, and assign to gwfcng + do j=1,jmax + do k=1, kmax + gwfcng_x(:,j,k) = gwfcng_x_reshaped(k, (j-1)*imax+1:j*imax) + gwfcng_y(:,j,k) = gwfcng_y_reshaped(k, (j-1)*imax+1:j*imax) + end do + end do + + ! Cleanup + call torch_tensor_delete(model_input_arr(1)) + call torch_tensor_delete(model_input_arr(2)) + call torch_tensor_delete(model_input_arr(3)) + call torch_tensor_delete(gwfcng_x_tensor) + call torch_tensor_delete(gwfcng_y_tensor) + deallocate( uuu_reshaped ) + deallocate( vvv_reshaped ) + deallocate( lat_reshaped ) + deallocate( psfc_reshaped ) + deallocate( gwfcng_x_reshaped ) + deallocate( gwfcng_y_reshaped ) + + +end subroutine cg_drag_ML + + +!#################################################################### + +end module cg_drag_ML_mod diff --git a/src/atmos_param/cg_drag/tensorflow.f90 b/src/atmos_param/cg_drag/tensorflow.f90 new file mode 100644 index 0000000..05e05c7 --- /dev/null +++ b/src/atmos_param/cg_drag/tensorflow.f90 @@ -0,0 +1,365 @@ + !----------------------------------------------------------------- + ! This module was auto-generated by process_model, + ! and then edited to match the signatures required. + ! + !----------------------------------------------------------------- + +module cg_drag_ML_mod + use TF_Types + use TF_Interface + +use constants_mod, only: RADIAN + + implicit none + + public cg_drag_ML_init, & + cg_drag_ML, & + cg_drag_ML_end, & + associate_tensor + + ! Interface for `associate_tensor` functions + interface associate_tensor + module procedure r64_2_associate_tensor + end interface associate_tensor + + ! Each model needs a session and a graph variable. + ! Model: saved_model/ + type(TF_Session) :: model_session_1 + type(TF_Graph) :: model_graph_1 + + ! Input and output details + type(TF_Output), dimension(3) :: inputs_1 + type(TF_Output), dimension(1) :: outputs_1 + + contains + + subroutine cg_drag_ML_init(model_dir, model_name) + + !----------------------------------------------------------------- + ! cg_drag_ML_init is called from cg_drag_init and initialises + ! anything required for the ML calculation of cg_drag such as + ! an ML model + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! intent(in) variables: + ! + ! model_dir full filepath to the model directory + ! model_name filename of the TorchScript model + ! + ! Note that the TensorFlow model path is a directory name + ! so model_name will be ignored. + ! + !----------------------------------------------------------------- + ! Parameters + character(*) :: model_dir, model_name + + ! Filenames for directories containing models + character(1024), dimension(1) :: model_dirs + + character(5), dimension(1, 1) :: tags + integer :: i + + ! Assign the tags + tags(1, 1) = 'serve' + + ! Rather than hard-coding the filenames here, you probably + ! want to load them from a config file or similar. + model_dirs(1) = trim(model_dir) // trim(model_name) + + ! Load all the models. + ! If you have a model with different needs (tags, etc) + ! edit this to handle that model separately. + + ! Model: saved_model/ + model_graph_1 = TF_NewGraph() + call load_model(model_session_1, & + model_graph_1, & + tags(:, 1), model_dirs(1)) + + ! Populate the input / output operations. + ! Input for 'saved_model/' input 'input_lat' + inputs_1(1)%oper = TF_GraphOperationByName( & + model_graph_1, & + 'serving_default_input_lat' & + ) + if (.not.c_associated(inputs_1(1)%oper%p)) then + write(*,*)'inputs_1(1) not associated' + stop + endif + inputs_1(1)%index = 0 + + ! Input for 'saved_model/' input 'input_press' + inputs_1(2)%oper = TF_GraphOperationByName( & + model_graph_1, & + 'serving_default_input_press' & + ) + if (.not.c_associated(inputs_1(2)%oper%p)) then + write(*,*)'inputs_1(2) not associated' + stop + endif + inputs_1(2)%index = 0 + + ! Input for 'saved_model/' input 'input_wind' + inputs_1(3)%oper = TF_GraphOperationByName( & + model_graph_1, & + 'serving_default_input_wind' & + ) + if (.not.c_associated(inputs_1(3)%oper%p)) then + write(*,*)'inputs_1(3) not associated' + stop + endif + inputs_1(3)%index = 0 + + ! Output for 'saved_model/' output 'normalization' + outputs_1(1)%oper = TF_GraphOperationByName( & + model_graph_1, & + 'StatefulPartitionedCall' & + ) + if (.not.c_associated(outputs_1(1)%oper%p)) then + write(*,*)'outputs_1(1) not associated' + stop + endif + outputs_1(1)%index = 0 + + end subroutine cg_drag_ML_init + + subroutine load_model(session, graph, tags, model_dir) + + type(TF_Session) :: session + type(TF_Graph) :: graph + character(*), dimension(:) :: tags + character(*) :: model_dir + + type(TF_SessionOptions) :: sessionoptions + type(TF_Status) :: stat + character(100) :: message + + sessionoptions = TF_NewSessionOptions() + stat = TF_NewStatus() + + session = TF_LoadSessionFromSavedModel(sessionoptions, & + model_dir, & + tags, size(tags, 1), graph, stat) + + if (TF_GetCode( stat ) .ne. TF_OK) then + call TF_Message( stat, message ) + write(*,*) TF_GetCode( stat ), message + stop + endif + + call TF_DeleteSessionOptions(sessionoptions) + call TF_DeleteStatus(stat) + + end subroutine load_model + + + subroutine cg_drag_ML_calc( & + session, input_tensors, output_tensors & + ) + + type(TF_Session) :: session + type(TF_Tensor), dimension(:) :: input_tensors, output_tensors + + type(TF_Status) :: stat + character(100) :: message + type(TF_Operation), dimension(1) :: target_opers + + stat = TF_NewStatus() + + call TF_SessionRun( & + session, & + inputs_1, input_tensors, & + size(input_tensors), & + outputs_1, output_tensors, & + size(output_tensors), & + target_opers, 0, stat & + ) + if (TF_GetCode(stat) .ne. TF_OK) then + call TF_Message(stat, message) + write(*,*) TF_GetCode(stat), message + stop + endif + call TF_DeleteStatus(stat) + + end subroutine cg_drag_ML_calc + +subroutine cg_drag_ML(uuu, vvv, psfc, lat, gwfcng_x, gwfcng_y) + + !----------------------------------------------------------------- + ! cg_drag_ML returns the x and y gravity wave drag forcing + ! terms following calculation using an external neural net. + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! intent(in) variables: + ! + ! is,js starting subdomain i,j indices of data in + ! the physics_window being integrated + ! uuu,vvv arrays of model u and v wind + ! psfc array of model surface pressure + ! lat array of model latitudes at cell boundaries [radians] + ! + ! intent(out) variables: + ! + ! gwfcng_x time tendency for u eqn due to gravity-wave forcing + ! [ m/s^2 ] + ! gwfcng_y time tendency for v eqn due to gravity-wave forcing + ! [ m/s^2 ] + ! + !----------------------------------------------------------------- + + real, dimension(:,:,:), intent(in) :: uuu, vvv + real, dimension(:,:), intent(in) :: lat, psfc + + real, dimension(:,:,:), intent(out), target :: gwfcng_x, gwfcng_y + + !----------------------------------------------------------------- + + !------------------------------------------------------------------- + ! local variables: + ! + ! dtdz temperature lapse rate [ deg K/m ] + ! + !--------------------------------------------------------------------- + + real, dimension(:,:), allocatable, target :: uuu_reshaped, vvv_reshaped + real, dimension(:,:), allocatable, target :: lat_reshaped, psfc_reshaped + + integer :: imax, jmax, kmax, j, k + + integer(c_int), parameter :: dims_out = 2 + integer(c_int64_t) :: shape_out(dims_out) + + ! Set up types of input and output data and the interface with C + type(TF_Tensor), dimension(1) :: gwfcng_x_tensors, gwfcng_y_tensors + integer(c_int), parameter :: n_inputs = 3 + type(TF_Tensor), dimension(n_inputs) :: model_input_arr + real, dimension(:,:), pointer :: output_x_data_ptr, output_y_data_ptr + + !---------------------------------------------------------------- + + ! reshape tensors as required + imax = size(uuu, 1) + jmax = size(uuu, 2) + kmax = size(uuu, 3) + + ! Note that the '1D' tensor has 2 dimensions, one of which is size 1 + shape_out = (/ kmax, imax*jmax /) + + ! flatten data (nlat, nlon, n) --> (nlat*nlon, n) + allocate( uuu_reshaped(kmax, imax*jmax) ) + allocate( vvv_reshaped(kmax, imax*jmax) ) + allocate( lat_reshaped(1, imax*jmax) ) + allocate( psfc_reshaped(1, imax*jmax) ) + + do j=1,jmax + do k=1, kmax + uuu_reshaped(k, (j-1)*imax+1:j*imax) = uuu(:,j,k) + vvv_reshaped(k, (j-1)*imax+1:j*imax) = vvv(:,j,k) + end do + lat_reshaped(1, (j-1)*imax+1:j*imax) = lat(:,j)*RADIAN + psfc_reshaped(1, (j-1)*imax+1:j*imax) = psfc(:,j) + end do + + ! Create input/output tensors from the above arrays + model_input_arr(2) = r64_2_associate_tensor(lat_reshaped) + model_input_arr(1) = r64_2_associate_tensor(psfc_reshaped) + + ! Zonal + model_input_arr(3) = r64_2_associate_tensor(uuu_reshaped) + + ! Run model and Infer + call cg_drag_ML_calc(model_session_1, model_input_arr, gwfcng_x_tensors) + + ! Meridional + call TF_DeleteTensor(model_input_arr(3)) + model_input_arr(3) = r64_2_associate_tensor(vvv_reshaped) + ! Run model and Infer + call cg_drag_ML_calc(model_session_1, model_input_arr, gwfcng_y_tensors) + + + ! Convert back into fortran types, reshape, and assign to gwfcng + call c_f_pointer(TF_TensorData(gwfcng_x_tensors(1)), output_x_data_ptr, shape_out) + call c_f_pointer(TF_TensorData(gwfcng_y_tensors(1)), output_y_data_ptr, shape_out) + + do j=1,jmax + do k=1, kmax + gwfcng_x(:,j,k) = output_x_data_ptr(k, (j-1)*imax+1:j*imax) + gwfcng_y(:,j,k) = output_y_data_ptr(k, (j-1)*imax+1:j*imax) + end do + end do + + ! Cleanup + call TF_DeleteTensor(model_input_arr(1)) + call TF_DeleteTensor(model_input_arr(2)) + call TF_DeleteTensor(model_input_arr(3)) + call TF_DeleteTensor(gwfcng_x_tensors(1)) + call TF_DeleteTensor(gwfcng_y_tensors(1)) + deallocate( uuu_reshaped ) + deallocate( vvv_reshaped ) + deallocate( lat_reshaped ) + deallocate( psfc_reshaped ) + + +end subroutine cg_drag_ML + subroutine cg_drag_ML_end() + + type(TF_Status) :: stat + character(100) :: message + + stat = TF_NewStatus() + ! Delete the model variables. + ! Model: saved_model/ + call TF_DeleteGraph(model_graph_1) + call TF_DeleteSession(model_session_1, & + stat) + if (TF_GetCode(stat) .ne. TF_OK) then + call TF_Message(stat, message) + write(*,*) TF_GetCode(stat), message + ! we don't stop here so all resources can try to delete + endif + call TF_DeleteStatus(stat) + + end subroutine cg_drag_ML_end + + function r64_2_associate_tensor(input_array, input_shape, input_size) + type(TF_Tensor) :: r64_2_associate_tensor + real, dimension(:, :), target :: input_array + integer(kind=c_int64_t), dimension(2), optional :: input_shape + integer(kind=c_size_t), optional :: input_size + + integer(kind=c_int64_t), dimension(2) :: input_shape_act + integer(kind=c_int64_t) :: swap + integer :: i, sz_inp_act + integer(kind=c_size_t) :: input_size_act + + if (.not.present(input_shape)) then + input_shape_act = shape(input_array) + else + input_shape_act = input_shape + end if + + ! Reverse the index order of the shape. + sz_inp_act = size(input_shape_act) + 1 ! 1-indexed arrays + do i = 1, sz_inp_act / 2 + swap = input_shape_act(i) + input_shape_act(i) = input_shape_act(sz_inp_act - i) + input_shape_act(sz_inp_act - i) = swap + enddo + + if (.not.present(input_size)) then + ! sizeof is non-standard but seems to be widely supported. + input_size_act = int(sizeof(input_array), kind=c_size_t) + else + input_size_act = input_size + end if + + r64_2_associate_tensor = TF_NewTensor(TF_DOUBLE, input_shape_act, 2, & + c_loc(input_array), input_size_act) + + end function r64_2_associate_tensor + +end module cg_drag_ML_mod diff --git a/src/atmos_param/damping_driver/damping_driver.f90 b/src/atmos_param/damping_driver/damping_driver.f90 index 2d44d2d..d26382d 100644 --- a/src/atmos_param/damping_driver/damping_driver.f90 +++ b/src/atmos_param/damping_driver/damping_driver.f90 @@ -115,19 +115,18 @@ module damping_driver_mod !####################################################################### - subroutine damping_driver (is, js, lat, Time, delt, pfull, phalf, zfull, zhalf, & - u, v, t, q, r, udt, vdt, tdt, qdt, rdt, & -! mask, kbot) - z_pbl, mask, kbot) + subroutine damping_driver (is, ie, js, je, lat, Time, delt, pfull, phalf, zfull, zhalf, & + u, v, t, q, r, udt, vdt, tdt, qdt, rdt, & ! mask, kbot) + z_pbl, temp, mask, kbot) !----------------------------------------------------------------------- - integer, intent(in) :: is, js + integer, intent(in) :: is, ie, js, je real, dimension(:,:), intent(in) :: lat type(time_type), intent(in) :: Time real, intent(in) :: delt real, intent(in), dimension(:,:,:) :: pfull, phalf, & zfull, zhalf, & - u, v, t, q + u, v, t, q, temp real, intent(in), dimension(:,:,:,:) :: r real, intent(inout), dimension(:,:,:) :: udt,vdt,tdt,qdt real, intent(inout), dimension(:,:,:,:) :: rdt @@ -136,7 +135,7 @@ subroutine damping_driver (is, js, lat, Time, delt, pfull, phalf, zfull, zhalf, integer, intent(in), dimension(:,:), optional :: kbot !----------------------------------------------------------------------- - real, dimension(size(udt,1),size(udt,2)) :: diag2 + real, dimension(size(udt,1),size(udt,2)) :: diag2, psfc real, dimension(size(udt,1),size(udt,2)) :: taubx, tauby real, dimension(size(udt,1),size(udt,2),size(udt,3)) :: taus real, dimension(size(udt,1),size(udt,2),size(udt,3)) :: utnd, vtnd, & @@ -252,7 +251,8 @@ subroutine damping_driver (is, js, lat, Time, delt, pfull, phalf, zfull, zhalf, !mj updating call to riga version of cg_drag !call cg_drag_calc (is, js, lat, pfull, zfull, t, u, Time, & ! delt, utnd) - call cg_drag_calc (is, js, lat, pfull, zfull, t, u, v, Time, delt, utnd, vtnd) + call get_psfc(is, ie, js, je, phalf, temp, psfc, kbot) + call cg_drag_calc (is, js, lat, pfull, zfull, psfc, t, u, v, Time, delt, utnd, vtnd) udt = udt + utnd vdt = vdt + vtnd !mj @@ -615,6 +615,76 @@ subroutine rayleigh (dt, pres, u, v, udt, vdt, tdt) end subroutine rayleigh + +subroutine get_psfc(is, ie, js, je, phalf, t, psfc, kbot) + + !--------------------------------------------------------------------- + ! get_psfc just gets surface pressure. + !--------------------------------------------------------------------- + integer, intent(in) :: is, ie, js, je + real, dimension(:,:,:), intent(in) :: phalf, t + real, dimension(:,:), intent(out) :: psfc + integer, dimension(:,:), intent(in), optional :: kbot + + + !--------------------------------------------------------------------- + ! intent(in) variables: + ! + ! is,ie,js,je starting/ending subdomain i,j indices of data in + ! the physics_window being integrated + ! phalf pressure at half levels [ kg / (m s^2) ] + ! t temperature at full levels [ deg K] + ! + ! intent(inout) variables: + ! psfc surface pressure + ! [ (kg /( m s^2) ] + ! + ! intent(in), optional variables: + ! + ! kbot present when running eta vertical coordinate, + ! index of lowest model level above ground (???) + !--------------------------------------------------------------------- + + !--------------------------------------------------------------------- + ! local variables + + integer :: i, j, kb + integer :: kmax +! real, dimension (size(t,1), size(t,2), size(t,3)+1) :: phalf2 + + !--------------------------------------------------------------------- + ! local variables + ! + ! i, j do loop indices + ! kb vertical index of lowest atmospheric level (when + ! using eta coordinates) + ! kmax number of model layers + ! + !--------------------------------------------------------------------- + !---------------------------------------------------------------------- + ! define the number of model layers. + !---------------------------------------------------------------------- + kmax = size(t,3) + ! print *, 'we are NOT doing data override.' + !phalf2(:,:,kmax+1) = phalf(:,:,kmax+1) + + ! allocate psfc(size(t,1),size(t,2)) + !-------------------------------------------------------------------- + ! define values of surface pressure. + !-------------------------------------------------------------------- + if (present(kbot)) then + do j=1,je-js+1 + do i=1,ie-is+1 + kb = kbot(i,j) + psfc(i,j) = phalf(i,j,kb+1) + end do + end do + else + psfc(:,:) = phalf(:,:,kmax+1) + endif + + +end subroutine get_psfc !####################################################################### end module damping_driver_mod diff --git a/src/atmos_param/physics_driver/physics_driver.f90 b/src/atmos_param/physics_driver/physics_driver.f90 index 74c3aca..b0cf8ce 100644 --- a/src/atmos_param/physics_driver/physics_driver.f90 +++ b/src/atmos_param/physics_driver/physics_driver.f90 @@ -1303,11 +1303,11 @@ subroutine physics_driver_down (is, ie, js, je, & z_pbl(:,:) = pbltop(is:ie,js:je) if(do_damping) then call mpp_clock_begin ( damping_clock ) - call damping_driver (is, js, lat, Time_next, dt, & + call damping_driver (is, ie, js, je, lat, Time_next, dt, & p_full, p_half, z_full, z_half, & um, vm, tm, qm, rm(:,:,:,1:ntp), & udt, vdt, tdt, qdt, rdt,& - z_pbl , mask=mask, kbot=kbot) + z_pbl, t, mask=mask, kbot=kbot) call mpp_clock_end ( damping_clock ) endif diff --git a/src/atmos_shared/CMakeLists.txt b/src/atmos_shared/CMakeLists.txt new file mode 100644 index 0000000..6c6805f --- /dev/null +++ b/src/atmos_shared/CMakeLists.txt @@ -0,0 +1,12 @@ +set ( ATMOS_SHARED_SOURCES +tracer_driver/atmos_convection_tracer.f90 +tracer_driver/atmos_tracer_driver.f90 +tracer_driver/atmos_radon.f90 +tracer_driver/atmos_carbon_aerosol.f90 +tracer_driver/atmos_sulfur_hex.f90 +tracer_driver/atmos_tracer_utilities.f90 +interpolator/interpolator.F90 +vert_advection/vert_advection.f90 +) + +target_sources ( mima.x PRIVATE ${ATMOS_SHARED_SOURCES} ) diff --git a/src/atmos_spectral/CMakeLists.txt b/src/atmos_spectral/CMakeLists.txt new file mode 100644 index 0000000..6d76f41 --- /dev/null +++ b/src/atmos_spectral/CMakeLists.txt @@ -0,0 +1,32 @@ +set ( ATMOS_SPECTRAL_SOURCES +# driver/solo/atmosphere.f90 +driver/coupled/mcm_mca_lsc.f90 +driver/coupled/mcm_moist_processes.f90 +driver/coupled/spectral_physics.f90 +driver/coupled/atmosphere.f90 +model/leapfrog.f90 +model/global_integral.f90 +model/water_borrowing.f90 +model/every_step_diagnostics.f90 +model/tracer_type.f90 +model/fv_advection.f90 +model/press_and_geopot.f90 +model/implicit.f90 +model/spectral_dynamics.f90 +model/spectral_damping.f90 +model/matrix_invert.f90 +# init/spectral_init_cond.f90.axi +init/vert_coordinate.f90 +init/spectral_initialize_fields.f90 +# init/spectral_init_cond.f90.nonaxi +init/spectral_init_cond.f90 +init/topog_regularization.f90 +tools/spec_mpp.f90 +tools/gauss_and_legendre.f90 +tools/transforms.f90 +tools/spherical.f90 +tools/spherical_fourier.f90 +tools/grid_fourier.f90 +) + +target_sources( mima.x PRIVATE ${ATMOS_SPECTRAL_SOURCES} ) diff --git a/src/coupler/CMakeLists.txt b/src/coupler/CMakeLists.txt new file mode 100644 index 0000000..926daf0 --- /dev/null +++ b/src/coupler/CMakeLists.txt @@ -0,0 +1,10 @@ +set ( COUPLER_SOURCES +simple_surface.f90 +coupler_main.f90 +# No longer seems to be required in new MiMA? +#flux_exchange.f90 +surface_flux.f90 +) + +# NB this is where the executable is defined. +target_sources ( mima.x PRIVATE ${COUPLER_SOURCES} ) diff --git a/src/ice_param/CMakeLists.txt b/src/ice_param/CMakeLists.txt new file mode 100644 index 0000000..5e5a8a4 --- /dev/null +++ b/src/ice_param/CMakeLists.txt @@ -0,0 +1,5 @@ +set ( ICE_PARAM_SOURCES +ocean_rough.f90 +) + +target_sources( mima.x PRIVATE ${ICE_PARAM_SOURCES} ) diff --git a/src/shared/CMakeLists.txt b/src/shared/CMakeLists.txt new file mode 100644 index 0000000..390b442 --- /dev/null +++ b/src/shared/CMakeLists.txt @@ -0,0 +1,116 @@ +set (SHARED_SOURCES +# sat_vapor_pres/sat_vapor_pres.f90.am2rad +sat_vapor_pres/sat_vapor_pres.f90 +tracer_manager/tracer_manager.F90 +random_numbers/MersenneTwister.f90 +random_numbers/random_numbers.f90 +constants/constants.f90 +time_manager/get_cal_time.f90 +time_manager/time_manager.f90 +tridiagonal/tridiagonal.f90 +axis_utils/axis_utils.F90 +column_diagnostics/column_diagnostics.f90 +field_manager/parse.inc +field_manager/field_manager.F90 +fms/read_data_3d.inc +fms/read_data_4d.inc +fms/fms.f90 +fms/read_data_2d.inc +fms/fms_io.F90 +fms/write_data.inc +topography/topography.f90 +topography/gaussian_topog.f90 +time_interp/time_interp_external.F90 +time_interp/time_interp.f90 +include/fms_platform.h +fft/fft99.f90 +fft/fft.F90 +platform/platform.F90 +data_override/data_override.F90 +diag_manager/diag_output.f90 +diag_manager/diag_axis.f90 +diag_manager/diag_manager.f90 +horiz_interp/horiz_interp_spherical.f90 +horiz_interp/horiz_interp_type.f90 +horiz_interp/horiz_interp_conserve.f90 +horiz_interp/horiz_interp.f90 +horiz_interp/horiz_interp_bilinear.f90 +memutils/memutils.F90 +mpp/mpp_io_connect.F90 +mpp/mpp_domains_util.F90 +mpp/mpp_domains_define.F90 +mpp/mpp_datatype.F90 +mpp/mpp_io.F90 +mpp/mpp_domains_misc.F90 +mpp/mpp_domains_comm.F90 +mpp/include/mpp_do_update_caf.h +mpp/include/mpp_sum_nocomm.h +mpp/include/mpp_global_reduce.h +mpp/include/mpp_reduce_gsm.h +mpp/include/mpp_comm_nocomm.inc +mpp/include/mpp_global_sum.h +mpp/include/mpp_global_field.h +mpp/include/mpp_data_mpi.inc +mpp/include/mpp_do_update_old.h +mpp/include/mpp_do_global_field_new.h +mpp/include/mpp_do_updateV_caf.h +mpp/include/mpp_domains_comm.h +mpp/include/mpp_sum.inc +mpp/include/mpp_reduce_nocomm.h +mpp/include/mpp_do_redistribute_caf.h +mpp/include/mpp_do_update_new.h +mpp/include/mpp_transmit_mpi.h +mpp/include/mpp_sum_sma.h +mpp/include/mpp_comm_sma.inc +mpp/include/mpp_util_sma.inc +mpp/include/mpp_sum_mpi.h +mpp/include/mpp_do_updateV_gsm.h +mpp/include/mpp_sum_gsm.h +mpp/include/mpp_chksum_int.h +mpp/include/mpp_chksum.h +mpp/include/mpp_transmit_sma.h +mpp/include/mpp_sum_caf.h +mpp/include/mpp_do_update_gsm.h +mpp/include/mpp_reduce_mpi.h +mpp/include/mpp_do_redistribute_new.h +mpp/include/mpp_util_nocomm.inc +mpp/include/mpp_datatype.h +mpp/include/mpp_do_redistribute_old.h +mpp/include/mpp_update_domains2D.h +mpp/include/mpp_transmit.inc +mpp/include/mpp_do_updateV_old.h +mpp/include/mpp_util_mpi.inc +mpp/include/mpp_write.h +mpp/include/mpp_reduce_caf.h +mpp/include/mpp_data_sma.inc +mpp/include/mpp_do_updateV_new.h +mpp/include/mpp_do_global_field_gsm.h +mpp/include/mpp_do_redistribute_gsm.h +mpp/include/mpp_reduce_sma.h +mpp/include/mpp_comm_mpi.inc +mpp/include/mpp_do_global_field_caf.h +mpp/include/mpp_do_global_field_old.h +mpp/include/mpp_data_nocomm.inc +mpp/include/mpp_read_2Ddecomp.h +mpp/include/system_clock.h +mpp/include/mpp_write_2Ddecomp.h +mpp/include/mpp_transmit_nocomm.h +mpp/mpp_io_read.F90 +mpp/mpp_data.F90 +mpp/mpp_io_misc.F90 +mpp/mpp_io_write.F90 +mpp/mpp_util.F90 +mpp/mpp.F90 +mpp/mpp_comm.F90 +mpp/mpp_domains_reduce.F90 +mpp/mpp_domains.F90 +mpp/mpp_parameter.F90 +mpp/mpp_io_util.F90 +) + +target_sources ( mima.x PRIVATE ${SHARED_SOURCES} ) +target_sources ( mima_c PRIVATE +memutils/memuse.c +mpp/nsclock.c +mpp/threadloc.c +) diff --git a/src/shared/forpy/forpy_mod.f90 b/src/shared/forpy/forpy_mod.f90 new file mode 100644 index 0000000..4e3fa2d --- /dev/null +++ b/src/shared/forpy/forpy_mod.f90 @@ -0,0 +1,11883 @@ +! Copyright (C) 2017-2020 Elias Rabel +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! 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 Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with this program. If not, see . + +module forpy_mod +!! author: Elias Rabel +!! +!! Forpy: A library for Fortran-Python interoperability. +!! +!! Forpy allows you to use Python features within Fortran ("Python in Fortran") +!! For example: Python modules, datastructures such as list, dict, tuple +!! Furthermore you can write Python (extension) modules in Fortran ("Fortran in Python") + +! Contact: +! Let me know, if you find this library useful: +! Mail: ylikx.0 at gmail dot com +! Web: https://github.com/ylikx + +! This project uses the fypp preprocessor (https://github.com/aradi/fypp) +! to generate the code +! Do not edit forpy_mod.F90, edit forpy_mod.fypp +! + +#ifdef PYTHON2_32 +#define PYTHON2 +#endif + +use, intrinsic :: iso_c_binding, only: C_CHAR, C_NULL_CHAR, C_INT, C_LONG, C_LONG_LONG, C_NEW_LINE, c_ptr, C_DOUBLE, & + C_DOUBLE_COMPLEX, c_associated, C_NULL_PTR, c_loc, c_f_pointer, & + c_funptr, c_funloc, C_NULL_FUNPTR, C_INTPTR_T + +use, intrinsic :: iso_fortran_env, only: int64, int32, real32, real64 + +implicit none + +public :: object, type_py, list, dict, tuple, bytes, str, unicode, module_py, & +NoneType, ndarray, Sequence, MutableSequence, ImmutableSequence, Mapping, & +tuple_create, list_create, dict_create, bytes_create, str_create, & +unicode_create, NoneType_create, ndarray_create, ndarray_create_nocopy, & +ndarray_create_empty, ndarray_create_zeros, ndarray_create_ones, & +import_py, call_py, call_py_noret, assign_py, cast, cast_nonstrict, & +PythonMethodTable, PythonModule, forpy_initialize, & +forpy_finalize, is_long, is_list, is_tuple, is_bytes, is_dict, & +is_float, is_complex, is_bool, is_unicode, is_int, is_str, is_none, & +is_null, is_ndarray, exception_matches, err_clear, err_print, have_exception, & +raise_exception, print_py, get_sys_path, run_string, unsafe_cast_from_c_ptr + +! ERROR CODES +integer(kind=C_INT), public, parameter :: NO_NUMPY_ERROR = 2_C_INT +integer(kind=C_INT), public, parameter :: EXCEPTION_ERROR = -1_C_INT + +! Flags used for Python extension development +integer(kind=C_INT), public, parameter :: METH_VARARGS = 1_C_INT +integer(kind=C_INT), public, parameter :: METH_KEYWORDS = 2_C_INT +integer(kind=C_INT), public, parameter :: METH_NOARGS = 4_C_INT +integer(kind=C_INT), public, parameter :: METH_O = 8_C_INT + +integer, public, parameter :: PY_SSIZE_T_KIND = C_INTPTR_T + +PRIVATE + +! These global variables shall be set in +! forpy_initialize only and never changed afterwards! +integer, private, save :: global_forpy_initialized = 0 +type(c_ptr), private, save :: global_numpy_mod = C_NULL_PTR +type(c_ptr), private, save :: global_numpy_asarray_method = C_NULL_PTR +! the location of the singleton Python Py_NoneStruct method +! initialised in forpy_initialize - if not called, working with None +! is impossible +type(c_ptr), private, save :: global_Py_NoneStruct_ptr = C_NULL_PTR + +! Similar for the 2 singleton bools +type(c_ptr), private, save :: global_Py_TrueStruct_ptr = C_NULL_PTR +type(c_ptr), private, save :: global_Py_FalseStruct_ptr = C_NULL_PTR + +type(c_ptr), private, save :: global_numpy_ndarray_typeobj = C_NULL_PTR + +!pointers to type-objects of fundamental datatypes +!initialised in forpy_initialize +type(c_ptr), private, save :: global_pyfloat_type_ptr = C_NULL_PTR +type(c_ptr), private, save :: global_pycomplex_type_ptr = C_NULL_PTR +type(c_ptr), private, save :: global_pybool_type_ptr = C_NULL_PTR +type(c_ptr), private, save :: global_pyunicode_type_ptr = C_NULL_PTR + +type, bind(c) :: Py_buffer + type(c_ptr) :: buf + type(c_ptr) :: obj + integer(kind=PY_SSIZE_T_KIND) :: len + integer(kind=PY_SSIZE_T_KIND) :: itemsize + integer(kind=C_INT) :: readonly + integer(kind=C_INT) :: ndim + type(c_ptr) :: format + type(c_ptr) :: shape + type(c_ptr) :: strides + type(c_ptr) :: suboffsets +#ifdef PYTHON2 + integer(kind=PY_SSIZE_T_KIND) :: smalltable(2) +#endif + type(c_ptr) :: internal +end type + +type, bind(c) :: PyObject +#ifdef Py_DEBUG + type(c_ptr) :: ob_next + type(c_ptr) :: ob_prev +#endif + integer(kind=PY_SSIZE_T_KIND) :: ob_refcnt + type(c_ptr) :: ob_type +end type + +type, bind(c) :: PyTypeObject +#ifdef Py_DEBUG + type(c_ptr) :: ob_next + type(c_ptr) :: ob_prev +#endif + integer(kind=PY_SSIZE_T_KIND) :: ob_refcnt + type(c_ptr) :: ob_type + integer(kind=PY_SSIZE_T_KIND) :: ob_size + + type(c_ptr) :: tp_name ! For printing, in format "." + integer(kind=PY_SSIZE_T_KIND) :: tp_basicsize, tp_itemsize ! For allocation + + !Methods to implement standard operations + + type(c_ptr) :: tp_dealloc + type(c_ptr) :: tp_print + type(c_ptr) :: tp_getattr + type(c_ptr) :: tp_setattr + type(c_ptr) :: tp_compare + type(c_ptr) :: tp_repr + + !Method suites for standard classes + + type(c_ptr) :: tp_as_number + type(c_ptr) :: tp_as_sequence + type(c_ptr) :: tp_as_mapping + + ! More standard operations (here for binary compatibility) + + type(c_ptr) :: tp_hash + type(c_ptr) :: tp_call + type(c_ptr) :: tp_str + type(c_ptr) :: tp_getattro + type(c_ptr) :: tp_setattro + + ! Functions to access object as input/output buffer + type(c_ptr) :: tp_as_buffer + + !Flags to define presence of optional/expanded features + integer(kind=C_LONG) :: tp_flags ! Python2: long, Python3: unsigned long + + type(c_ptr) :: tp_doc ! Documentation string + + !call function for all accessible objects + type(c_ptr) :: tp_traverse + + ! delete references to contained objects + type(c_ptr) :: tp_clear + + ! Assigned meaning in release 2.1 + ! rich comparisons + type(c_ptr) :: tp_richcompare + + ! weak reference enabler + integer(kind=PY_SSIZE_T_KIND) :: tp_weaklistoffset + + !Added in release 2.2 + !Iterators + type(c_ptr) :: tp_iter + type(c_ptr) :: tp_iternext + + ! Attribute descriptor and subclassing stuff + type(c_ptr) :: tp_methods + type(c_ptr) :: tp_members + type(c_ptr) :: tp_getset + type(c_ptr) :: tp_base + type(c_ptr) :: tp_dict + type(c_ptr) :: tp_descr_get + type(c_ptr) :: tp_descr_set + integer(kind=PY_SSIZE_T_KIND) :: tp_dictoffset + type(c_ptr) :: tp_init + type(c_ptr) :: tp_alloc + type(c_ptr) :: tp_new + type(c_ptr) :: tp_free ! Low-level free-memory routine + type(c_ptr) :: tp_is_gc ! For PyObject_IS_GC + type(c_ptr) :: tp_bases + type(c_ptr) :: tp_mro ! method resolution order + type(c_ptr) :: tp_cache + type(c_ptr) :: tp_subclasses + type(c_ptr) :: tp_weaklist + type(c_ptr) :: tp_del + + ! Type attribute cache version tag. Added in version 2.6 + integer(kind=C_INT) :: tp_version_tag + + ! additionally Python3 has this field: + ! destructor tp_finalize; + ! we should be fine without it, since all we actually need is the offset + ! of tp_flags and we are not using arrays of PyTypeObjects + +end type + +type, bind(c) :: Py_complex + real(kind=C_DOUBLE) :: real_part + real(kind=C_DOUBLE) :: imag_part +end type + +type, bind(c) :: PyMethodDef + type(c_ptr) :: ml_name + type(c_funptr) :: ml_meth + integer(kind=C_INT) :: ml_flags + type(c_ptr) :: ml_doc +end type + +type, bind(c) :: PyModuleDef_Base + integer(kind=PY_SSIZE_T_KIND) :: ob_refcnt !PyObject_HEAD (init to 1) + type(c_ptr) :: ob_type ! from PyObject_HEAD (init to NULL) + + type(c_ptr) :: m_init + integer(kind=PY_SSIZE_T_KIND) :: m_index + type(c_ptr) :: m_copy +end type + +type, bind(c) :: PyModuleDef + type(PyModuleDef_Base) :: m_base + type(c_ptr) :: m_name + type(c_ptr) :: m_doc + integer(kind=PY_SSIZE_T_KIND) :: m_size + type(c_ptr) :: m_methods + type(c_ptr) :: m_slots + type(c_funptr) :: m_traverse + type(c_funptr) :: m_clear + type(c_funptr) :: m_free +end type + +interface + subroutine Py_Initialize() bind(c, name="Py_Initialize") + end subroutine + + function Py_IsInitialized() bind(c, name="Py_IsInitialized") result(r) + import C_INT + integer(kind=C_INT) :: r + end function + + subroutine Py_Finalize() bind(c, name="Py_Finalize") + end subroutine + + function PyImport_ImportModule(a_name) bind(c, name="PyImport_ImportModule") result(m) + import c_ptr, C_CHAR + character(kind=C_CHAR), dimension(*) :: a_name + type(c_ptr) :: m + end function + + function PyRun_SimpleString(command) bind(c, name="PyRun_SimpleString") result(r) + import C_INT, C_CHAR + character(kind=C_CHAR), dimension(*) :: command + integer(kind=C_INT) :: r + end function + + function PyList_New(len) bind(c, name="PyList_New") result(r) + import c_ptr, PY_SSIZE_T_KIND + integer(kind=PY_SSIZE_T_KIND), value :: len + type(c_ptr) :: r + end function + + function PyDict_New() bind(c, name="PyDict_New") result(r) + import c_ptr + type(c_ptr) :: r + end function + + !int PyList_Append(PyObject *list, PyObject *item) + function PyList_Append(list, item) bind(c, name="PyList_Append") result(r) + import c_ptr, C_INT + type(c_ptr), value :: list + type(c_ptr), value :: item + integer(kind=C_INT) :: r + end function + + function PyList_Sort(list) bind(c, name="PyList_Sort") result(r) + import c_ptr, C_INT + type(c_ptr), value :: list + integer(kind=C_INT) :: r + end function + + function PyList_Reverse(list) bind(c, name="PyList_Reverse") result(r) + import c_ptr, C_INT + type(c_ptr), value :: list + integer(kind=C_INT) :: r + end function + + !int PyList_Insert(PyObject *list, Py_ssize_t index, PyObject *item) + function PyList_Insert(list, index, item) bind(c, name="PyList_Insert") result(r) + import c_ptr, C_INT, PY_SSIZE_T_KIND + type(c_ptr), value :: list + integer(kind=PY_SSIZE_T_KIND), value :: index + type(c_ptr), value :: item + integer(kind=C_INT) :: r + end function + + !PyObject* PyLong_FromLongLong(long long ival) + function PyLong_FromLongLong(ival) bind(c, name="PyLong_FromLongLong") result(r) + import c_ptr, C_LONG_LONG + integer(kind=C_LONG_LONG), value :: ival + type(c_ptr) :: r + end function + + !PY_LONG_LONG PyLong_AsLongLongAndOverflow(PyObject *obj, int *overflow) + function PyLong_AsLongLongAndOverflow(obj, overflow) bind(c, name="PyLong_AsLongLongAndOverflow") result(r) + import c_ptr, C_LONG_LONG, C_INT + type(c_ptr), value :: obj + integer(kind=C_INT) :: overflow + integer(kind=C_LONG_LONG) :: r + end function + +#ifdef PYTHON2 + !PyObject* PyInt_FromLong(Py_ssize_t ival) + function PyInt_FromLong(ival) bind(c, name="PyInt_FromLong") result(r) + import c_ptr, C_LONG + integer(kind=C_LONG), value :: ival + type(c_ptr) :: r + end function +#endif + + !void Py_DecRef(PyObject *o) + subroutine Py_DecRef(o) bind(c, name="Py_DecRef") + import c_ptr + type(c_ptr), value :: o + end subroutine + + !void Py_IncRef(PyObject *o) + subroutine Py_IncRef(o) bind(c, name="Py_IncRef") + import c_ptr + type(c_ptr), value :: o + end subroutine + + !PyObject* PyObject_GetItem(PyObject *o, PyObject *key) + function PyObject_GetItem(o, key) bind(c, name="PyObject_GetItem") result(r) + import c_ptr + type(c_ptr), value :: o + type(c_ptr), value :: key + type(c_ptr) :: r + end function + + !int PyObject_SetItem(PyObject *o, PyObject *key, PyObject *v) + function PyObject_SetItem(o, key, v) bind(c, name="PyObject_SetItem") result(r) + import c_ptr, C_INT + type(c_ptr), value :: o + type(c_ptr), value :: key + type(c_ptr), value :: v + integer(kind=C_INT) :: r + end function + + !Py_ssize_t PyObject_Length(PyObject *o) + function PyObject_Length(o) bind(c, name="PyObject_Length") result(r) + import c_ptr, PY_SSIZE_T_KIND + type(c_ptr), value :: o + integer(kind=PY_SSIZE_T_KIND) :: r + end function + + !int PyObject_IsTrue(PyObject *o) + function PyObject_IsTrue(o) bind(c, name="PyObject_IsTrue") result(r) + import c_ptr, C_INT + type(c_ptr), value :: o + integer(kind=C_INT) :: r + end function + + !PyObject* PyObject_Str(PyObject *o) + function PyObject_Str(o) bind(c, name="PyObject_Str") result(r) + import c_ptr + type(c_ptr), value :: o + type(c_ptr) :: r + end function + + !int PySequence_SetItem(PyObject *o, Py_ssize_t i, PyObject *v) + function PySequence_SetItem(o, i, v) bind(c, name="PySequence_SetItem") result(r) + import c_ptr, C_INT, PY_SSIZE_T_KIND + type(c_ptr), value :: o + integer(kind=PY_SSIZE_T_KIND), value :: i + type(c_ptr), value :: v + integer(kind=C_INT) :: r + end function + + !PyObject* PySequence_GetItem(PyObject *o, Py_ssize_t i) + function PySequence_GetItem(o, i) bind(c, name="PySequence_GetItem") result(r) + import c_ptr, C_INT, PY_SSIZE_T_KIND + type(c_ptr), value :: o + integer(kind=PY_SSIZE_T_KIND), value :: i + type(c_ptr) :: r + end function + + !int PyTuple_SetItem(PyObject *p, Py_ssize_t pos, PyObject *o) + function PyTuple_SetItem(p, pos, o) bind(c, name="PyTuple_SetItem") result(r) + import c_ptr, C_INT, PY_SSIZE_T_KIND + type(c_ptr), value :: p + integer(kind=PY_SSIZE_T_KIND), value :: pos + type(c_ptr), value :: o + integer(kind=C_INT) :: r + end function + + !PyObject* PyTuple_New(Py_ssize_t len) + function PyTuple_New(len) bind(c, name="PyTuple_New") result(r) + import c_ptr, PY_SSIZE_T_KIND + integer(kind=PY_SSIZE_T_KIND), value :: len + type(c_ptr) :: r + end function + + !long long PyLong_AsLongLong(PyObject *io) + function PyLong_AsLongLong(io) bind(c, name="PyLong_AsLongLong") result(r) + import c_ptr, C_LONG_LONG + type(c_ptr), value :: io + integer(kind=C_LONG_LONG) :: r + end function + + !PyObject* PyFloat_FromDouble(double v) + function PyFloat_FromDouble(v) bind(c, name="PyFloat_FromDouble") result(r) + import c_ptr, C_DOUBLE + real(kind=C_DOUBLE), value :: v + type(c_ptr) :: r + end function + + !double PyFloat_AsDouble(PyObject *pyfloat) + function PyFloat_AsDouble(pyfloat) bind(c, name="PyFloat_AsDouble") result(r) + import c_ptr, C_DOUBLE + type(c_ptr), value :: pyfloat + real(kind=C_DOUBLE) :: r + end function + + function PyComplex_FromDoubles(re, im) bind(c, name="PyComplex_FromDoubles") result(r) + import c_ptr, C_DOUBLE + real(kind=C_DOUBLE), value :: re, im + type(c_ptr) :: r + end function + + function PyComplex_AsCComplex(obj) bind(c, name="PyComplex_AsCComplex") result(r) + import c_ptr, Py_complex + type(c_ptr), value :: obj + type(Py_complex) :: r + end function + + function PyErr_Occurred() bind(c, name="PyErr_Occurred") result(r) + import c_ptr + type(c_ptr) :: r + end function + + !void PyErr_Print() + subroutine PyErr_Print() bind(c, name="PyErr_Print") + end subroutine + + !void PyErr_Clear() + subroutine PyErr_Clear() bind(c, name="PyErr_Clear") + end subroutine + +#ifdef PYTHON2 + function PyBytes_FromStringAndSize(v, len) bind(c, name="PyString_FromStringAndSize") result(r) +#else + function PyBytes_FromStringAndSize(v, len) bind(c, name="PyBytes_FromStringAndSize") result(r) +#endif + import c_ptr, PY_SSIZE_T_KIND, C_CHAR + character(kind=C_CHAR), dimension(*), intent(in) :: v + integer(kind=PY_SSIZE_T_KIND), value :: len + type(c_ptr) :: r + end function + +#ifdef PYTHON2 + function PyBytes_FromString(v) bind(c, name="PyString_FromString") result(r) +#else + function PyBytes_FromString(v) bind(c, name="PyBytes_FromString") result(r) +#endif + import c_ptr, C_CHAR + character(kind=C_CHAR), dimension(*), intent(in) :: v + type(c_ptr) :: r + end function + + !char* PyBytes_AsString(PyObject *o) +#ifdef PYTHON2 + function PyBytes_AsString(o) bind(c, name="PyString_AsString") result(r) +#else + function PyBytes_AsString(o) bind(c, name="PyBytes_AsString") result(r) +#endif + import c_ptr + type(c_ptr), value :: o + type(c_ptr) :: r + end function + + ! PyObject* PyObject_GetAttr(PyObject *o, PyObject *attr_name) + function PyObject_GetAttr(o, attr_name) bind(c, name="PyObject_GetAttr") result(r) + import c_ptr + type(c_ptr), value :: o, attr_name + type(c_ptr) :: r + end function + + function PyObject_SetAttr(o, attr_name, v) bind(c, name="PyObject_SetAttr") result(r) + import c_ptr, C_INT + type(c_ptr), value :: o, attr_name, v + integer(kind=C_INT) :: r + end function + + !int PyObject_DelItem(PyObject *o, PyObject *key) + function PyObject_DelItem(o, key) bind(c, name="PyObject_DelItem") result(r) + import c_ptr, C_INT + type(c_ptr), value :: o, key + integer(kind=C_INT) :: r + end function + + !int PySequence_DelItem(PyObject *o, Py_ssize_t i) + function PySequence_DelItem(o, i) bind(c, name="PySequence_DelItem") result(r) + import c_ptr, C_INT, PY_SSIZE_T_KIND + type(c_ptr), value :: o + integer(kind=PY_SSIZE_T_KIND), value :: i + integer(kind=C_INT) :: r + end function + + !PyObject* PyObject_Call(PyObject *callable_object, PyObject *args, PyObject *kw) + function PyObject_Call(callable_object, args, kw) bind(c, name="PyObject_Call") result(r) + import c_ptr + type(c_ptr), value :: callable_object, args, kw + type(c_ptr) :: r + end function + + !PyObject *PyMemoryView_FromBuffer(Py_buffer *view) + function PyMemoryView_FromBuffer(view) bind(c, name="PyMemoryView_FromBuffer") result(r) + import Py_buffer, c_ptr + type(Py_buffer) :: view + type(c_ptr) :: r + end function + + !PyObject *PyMemoryView_FromObject(PyObject *obj) + function PyMemoryView_FromObject(obj) bind(c, name="PyMemoryView_FromObject") result(r) + import c_ptr + type(c_ptr), value :: obj + type(c_ptr) :: r + end function + + !int PyObject_GetBuffer(PyObject *obj, Py_buffer *view, int flags) + function PyObject_GetBuffer(obj, view, flags) bind(c, name="PyObject_GetBuffer") result(r) + import Py_buffer, c_ptr, C_INT + type(c_ptr), value :: obj + type(Py_buffer) :: view + integer(kind=C_INT), value :: flags + integer(kind=C_INT) :: r + end function + + !int PyBuffer_IsContiguous(Py_buffer *view, char fortran) + function PyBuffer_IsContiguous(view, fortran) bind(c, name="PyBuffer_IsContiguous") result(r) + import Py_buffer, C_INT, C_CHAR + type(Py_buffer) :: view + character(kind=C_CHAR), value :: fortran + integer(kind=C_INT) :: r + end function + + !void PyBuffer_Release(Py_buffer *view) + subroutine PyBuffer_Release(view) bind(c, name="PyBuffer_Release") + import Py_buffer + type(Py_buffer) :: view + end subroutine + + !int PyObject_IsInstance(PyObject *inst, PyObject *cls) + function PyObject_IsInstance(inst, cls) bind(c, name="PyObject_IsInstance") result(r) + import C_INT, c_ptr + type(c_ptr), value :: inst + type(c_ptr), value :: cls + integer(kind=C_INT) :: r + end function + + !int PyType_IsSubtype(PyTypeObject *a, PyTypeObject *b) + function PyType_IsSubtype(a, b) bind(c, name="PyType_IsSubtype") result(r) + import C_INT, c_ptr + type(c_ptr), value :: a + type(c_ptr), value :: b + integer(kind=C_INT) :: r + end function + + !PyObject* PyBool_FromLong(long v) + function PyBool_FromLong(v) bind(c, name="PyBool_FromLong") result(r) + import C_LONG, c_ptr + integer(kind=C_LONG), value :: v + type(c_ptr) :: r + end function + + !PyObject* PyUnicode_DecodeUTF8(const char *s, Py_ssize_t size, const char *errors) +#ifndef PYTHON2 + function PyUnicode_DecodeUTF8(s, size, errors) bind(c, name="PyUnicode_DecodeUTF8") result(r) +#endif + +#ifdef PYTHON2 +#ifdef PYTHON_NARROW + function PyUnicode_DecodeUTF8(s, size, errors) bind(c, name="PyUnicodeUCS2_DecodeUTF8") result(r) +#else + function PyUnicode_DecodeUTF8(s, size, errors) bind(c, name="PyUnicodeUCS4_DecodeUTF8") result(r) +#endif +#endif + import c_ptr, PY_SSIZE_T_KIND, C_CHAR + character(kind=C_CHAR), dimension(*) :: s + integer(kind=PY_SSIZE_T_KIND), value :: size + character(kind=C_CHAR), dimension(*) :: errors + type(c_ptr) :: r + end function + +#ifndef PYTHON2 + ! Since Python 3.3 in C-API + !char* PyUnicode_AsUTF8AndSize(PyObject *unicode, Py_ssize_t *size) + function PyUnicode_AsUTF8AndSize(unicode, size) bind(c, name="PyUnicode_AsUTF8AndSize") result(r) + import c_ptr, PY_SSIZE_T_KIND + type(c_ptr), value :: unicode + integer(kind=PY_SSIZE_T_KIND) :: size + type(c_ptr) :: r + end function +#endif + + !PyObject* PyUnicode_AsUTF8String(PyObject *unicode) +#ifdef PYTHON2 +#ifdef PYTHON2_NARROW + function PyUnicode_AsUTF8String(unicode) bind(c, name="PyUnicodeUCS2_AsUTF8String") result(r) +#else + function PyUnicode_AsUTF8String(unicode) bind(c, name="PyUnicodeUCS4_AsUTF8String") result(r) +#endif + import c_ptr + type(c_ptr), value :: unicode + type(c_ptr) :: r + end function +#endif + + function PyEval_GetBuiltins() bind(c, name="PyEval_GetBuiltins") result(r) + import c_ptr + type(c_ptr) :: r + end function + + !PyObject* PyDict_GetItemString(PyObject *p, const char *key) + function PyDict_GetItemString(p, key) bind(c, name="PyDict_GetItemString") result(r) + import c_ptr, C_CHAR + type(c_ptr), value :: p + character(kind=C_CHAR), dimension(*) :: key + type(c_ptr) :: r + end function + +!void PyErr_SetString(PyObject *type, const char *message) +subroutine PyErr_SetString(a_type, message) bind(c, name="PyErr_SetString") + import c_ptr, C_CHAR + type(c_ptr), value :: a_type + character(kind=C_CHAR), dimension(*) :: message +end subroutine + +!int PyErr_GivenExceptionMatches(PyObject *given, PyObject *exc) +function PyErr_GivenExceptionMatches(given, exc) bind(c, name="PyErr_GivenExceptionMatches") result(r) + import c_ptr, C_INT + type(c_ptr), value :: given, exc + integer(kind=C_INT) :: r +end function + +function PySequence_Tuple(o) bind(c, name="PySequence_Tuple") result(r) + import c_ptr + type(c_ptr), value :: o + type(c_ptr) :: r +end function + +function PySequence_List(o) bind(c, name="PySequence_List") result(r) + import c_ptr + type(c_ptr), value :: o + type(c_ptr) :: r +end function + +subroutine PyDict_Clear(p) bind(c, name="PyDict_Clear") + import c_ptr + type(c_ptr), value :: p +end subroutine + +function PyDict_Copy(p) bind(c, name="PyDict_Copy") result(r) + import c_ptr + type(c_ptr), value :: p + type(c_ptr) :: r +end function + +!PyObject* PyDict_Items(PyObject *p) +function PyDict_Items(p) bind(c, name="PyDict_Items") result(r) + import c_ptr + type(c_ptr), value :: p + type(c_ptr) :: r +end function + +!PyObject* PyDict_Keys(PyObject *p) +function PyDict_Keys(p) bind(c, name="PyDict_Keys") result(r) + import c_ptr + type(c_ptr), value :: p + type(c_ptr) :: r +end function + +!PyObject* PyDict_Values(PyObject *p) +function PyDict_Values(p) bind(c, name="PyDict_Values") result(r) + import c_ptr + type(c_ptr), value :: p + type(c_ptr) :: r +end function + +!void PyBuffer_FillContiguousStrides(int ndim, Py_ssize_t *shape, Py_ssize_t *strides, Py_ssize_t itemsize, char order) +subroutine PyBuffer_FillContiguousStrides(ndim, shape, strides, itemsize, order) bind(c, name="PyBuffer_FillContiguousStrides") + import c_ptr, C_INT, C_CHAR, PY_SSIZE_T_KIND + integer(kind=C_INT), value :: ndim + type(c_ptr), value :: shape + type(c_ptr), value :: strides + integer(kind=PY_SSIZE_T_KIND), value :: itemsize + character(kind=C_CHAR), value :: order +end subroutine + +function PySequence_Contains(o, a_value) bind(c, name="PySequence_Contains") result(r) + import c_ptr, C_INT + type(c_ptr), value :: o + type(c_ptr), value :: a_value + integer(kind=C_INT) :: r +end function + +function PySequence_Index(o, a_value) bind(c, name="PySequence_Index") result(r) + import c_ptr, PY_SSIZE_T_KIND + type(c_ptr), value :: o + type(c_ptr), value :: a_value + integer(kind=PY_SSIZE_T_KIND) :: r +end function + +function PySequence_Count(o, a_value) bind(c, name="PySequence_Count") result(r) + import c_ptr, PY_SSIZE_T_KIND + type(c_ptr), value :: o + type(c_ptr), value :: a_value + integer(kind=PY_SSIZE_T_KIND) :: r +end function + +function PyMapping_HasKey(o, a_value) bind(c, name="PyMapping_HasKey") result(r) + import c_ptr, C_INT + type(c_ptr), value :: o + type(c_ptr), value :: a_value + integer(kind=C_INT) :: r +end function + +function PySequence_Concat(o1, o2) bind(c, name="PySequence_Concat") result(r) + import c_ptr + type(c_ptr), value :: o1, o2 + type(c_ptr) :: r +end function + +!PyObject *PySys_GetObject(const char *name) +function PySys_GetObject(a_name) bind(c, name="PySys_GetObject") result(r) + import c_ptr, C_CHAR + character(kind=C_CHAR), dimension(*) :: a_name + type(c_ptr) :: r +end function + +#ifndef PYTHON2 +#ifndef Py_DEBUG +function PyModule_Create2(def, module_api_version) bind(c, name="PyModule_Create2") result(r) +#else +function PyModule_Create2(def, module_api_version) bind(c, name="PyModule_Create2TraceRefs") result(r) +#endif + import c_ptr, C_INT + type(c_ptr), value :: def + integer(kind=C_INT), value :: module_api_version + type(c_ptr) :: r +end function +#endif + +#ifdef PYTHON2 +!Python 2 only +!PyObject* Py_InitModule4(char *name, PyMethodDef *methods, char *doc, PyObject *self, int apiver) +#ifndef PYTHON2_32 +#ifndef Py_DEBUG +function Py_InitModule4(a_name, methods, doc, self, apiver) bind(c, name="Py_InitModule4_64") result(r) +#else +function Py_InitModule4(a_name, methods, doc, self, apiver) bind(c, name="Py_InitModule4TraceRefs_64") result(r) +#endif +#else +#ifndef Py_DEBUG +function Py_InitModule4(a_name, methods, doc, self, apiver) bind(c, name="Py_InitModule4") result(r) +#else +function Py_InitModule4(a_name, methods, doc, self, apiver) bind(c, name="Py_InitModule4TraceRefs") result(r) +#endif +#endif + import c_ptr, C_CHAR, C_INT + character(kind=C_CHAR), dimension(*) :: a_name + type(c_ptr), value :: methods + character(kind=C_CHAR), dimension(*) :: doc + type(c_ptr), value :: self + integer(kind=C_INT), value :: apiver + type(c_ptr) :: r +end function +#endif + +!int PyModule_AddObject(PyObject *module, const char *name, PyObject *value) +function PyModule_AddObject(a_module, a_name, a_value) bind(c, name="PyModule_AddObject") result(r) + import c_ptr, C_CHAR, C_INT + type(c_ptr), value :: a_module + character(kind=C_CHAR), dimension(*) :: a_name + type(c_ptr), value :: a_value + integer(kind=C_INT) :: r +end function + +#ifdef PYTHON2 +! Old-style Python2-only buffer protocol API function +!PyObject* PyBuffer_FromReadWriteMemory(void *ptr, Py_ssize_t size) +function PyBuffer_FromReadWriteMemory(ptr, the_size) bind(c, name="PyBuffer_FromReadWriteMemory") result(r) + import c_ptr, PY_SSIZE_T_KIND + type(c_ptr), value :: ptr + integer(kind=PY_SSIZE_T_KIND), value :: the_size + type(c_ptr) :: r +end function +#endif + +function strcmp(s1, s2) bind(c) result(r) + import c_ptr, C_INT + type(c_ptr), value :: s1, s2 + integer(kind=C_INT) :: r +end function + +end interface + +interface box_value +#ifdef PYTHON2 + module procedure box_value_int32 + module procedure box_value_int64 +#else + module procedure box_value_int32_as_long + module procedure box_value_int64_as_long +#endif + module procedure box_value_real32 + module procedure box_value_real64 + module procedure box_value_complex_real32 + module procedure box_value_complex_real64 + module procedure box_value_logical + module procedure box_value_chars + module procedure box_value_char_1d +end interface + +interface unbox_value + module procedure unbox_value_int32 + module procedure unbox_value_int64 + module procedure unbox_value_real32 + module procedure unbox_value_real64 + module procedure unbox_value_complex_real32 + module procedure unbox_value_complex_real64 + module procedure unbox_value_logical +#ifdef PYTHON2 + module procedure unbox_value_chars_py2 +#else + module procedure unbox_value_chars +#endif + module procedure unbox_value_char_1d +end interface + +interface tuple_from_array + module procedure tuple_from_array_int32 + module procedure tuple_from_array_int64 +end interface + +!--------- High-level API to Python's datastructures ------------------- + + + + + + +!> Type to represent an arbitrary Python object +type object + private + type(c_ptr) :: py_object = C_NULL_PTR + + contains + !> Call to allow for freeing of resources of this object. + procedure, public :: destroy => object_destroy + !> Get value of an attribute of this object + procedure, public :: getattribute => object_getattribute ! TODO: make generic? + !> Set value of an attribute of this object + procedure, public :: setattr => object_setattr + !> Delete an attribute of this object + procedure, public :: delattr => object_delattr + !> Get c_ptr representation of this object. For development of Python extension modules + procedure, public :: get_c_ptr => object_get_c_ptr +end type + +!> Type that represents a "class object". In Python class objects have the type 'type' which we name type_py here. +type, extends(object) :: type_py + +end type + +!> Abstract type that represents sequence objects. Elements of a sequence can be accessed by an index. +type, abstract, extends(object) :: Sequence + contains + procedure, private :: sequence_len_int32 + !> Get the length of the object (number of elements). + generic, public :: len => sequence_len_int32 + procedure, private :: sequence_count_int32 + generic, public :: count => sequence_count_int32 + + !index - does not support optional start and stop indices as the Python function does + procedure, private :: sequence_index_int32 + !> Get the first index of a value. + generic, public :: index => sequence_index_int32 + + procedure, private :: sequence_getitem_int32_object + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int32_object + procedure, private :: sequence_getitem_int32_int32 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int32_int32 + procedure, private :: sequence_getitem_int32_int64 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int32_int64 + procedure, private :: sequence_getitem_int32_real32 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int32_real32 + procedure, private :: sequence_getitem_int32_real64 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int32_real64 + procedure, private :: sequence_getitem_int32_complex_real32 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int32_complex_real32 + procedure, private :: sequence_getitem_int32_complex_real64 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int32_complex_real64 + procedure, private :: sequence_getitem_int32_logical + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int32_logical + procedure, private :: sequence_getitem_int32_char_1d + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int32_char_1d + procedure, private :: sequence_getitem_int32_chars + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int32_chars + + procedure, private :: sequence_len_int64 + !> Get the length of the object (number of elements). + generic, public :: len => sequence_len_int64 + procedure, private :: sequence_count_int64 + generic, public :: count => sequence_count_int64 + + !index - does not support optional start and stop indices as the Python function does + procedure, private :: sequence_index_int64 + !> Get the first index of a value. + generic, public :: index => sequence_index_int64 + + procedure, private :: sequence_getitem_int64_object + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int64_object + procedure, private :: sequence_getitem_int64_int32 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int64_int32 + procedure, private :: sequence_getitem_int64_int64 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int64_int64 + procedure, private :: sequence_getitem_int64_real32 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int64_real32 + procedure, private :: sequence_getitem_int64_real64 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int64_real64 + procedure, private :: sequence_getitem_int64_complex_real32 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int64_complex_real32 + procedure, private :: sequence_getitem_int64_complex_real64 + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int64_complex_real64 + procedure, private :: sequence_getitem_int64_logical + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int64_logical + procedure, private :: sequence_getitem_int64_char_1d + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int64_char_1d + procedure, private :: sequence_getitem_int64_chars + !> Get item at a certain index + generic, public :: getitem => sequence_getitem_int64_chars + + + !> Checks if a given item is contained in the sequence. + procedure, public :: contains => sequence_contains +end type + +!> Abstract type that represents a sequence, whose items can be changed. +type, abstract, extends(Sequence) :: MutableSequence + contains + procedure, private :: mutablesequence_setitem_int32_object + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int32_object + procedure, private :: mutablesequence_setitem_int32_int32 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int32_int32 + procedure, private :: mutablesequence_setitem_int32_int64 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int32_int64 + procedure, private :: mutablesequence_setitem_int32_real32 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int32_real32 + procedure, private :: mutablesequence_setitem_int32_real64 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int32_real64 + procedure, private :: mutablesequence_setitem_int32_complex_real32 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int32_complex_real32 + procedure, private :: mutablesequence_setitem_int32_complex_real64 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int32_complex_real64 + procedure, private :: mutablesequence_setitem_int32_logical + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int32_logical + procedure, private :: mutablesequence_setitem_int32_char_1d + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int32_char_1d + procedure, private :: mutablesequence_setitem_int32_chars + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int32_chars + procedure, private :: mutablesequence_setitem_int64_object + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int64_object + procedure, private :: mutablesequence_setitem_int64_int32 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int64_int32 + procedure, private :: mutablesequence_setitem_int64_int64 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int64_int64 + procedure, private :: mutablesequence_setitem_int64_real32 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int64_real32 + procedure, private :: mutablesequence_setitem_int64_real64 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int64_real64 + procedure, private :: mutablesequence_setitem_int64_complex_real32 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int64_complex_real32 + procedure, private :: mutablesequence_setitem_int64_complex_real64 + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int64_complex_real64 + procedure, private :: mutablesequence_setitem_int64_logical + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int64_logical + procedure, private :: mutablesequence_setitem_int64_char_1d + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int64_char_1d + procedure, private :: mutablesequence_setitem_int64_chars + !> Set an item at a given index + generic, public :: setitem => mutablesequence_setitem_int64_chars +end type + +!> Abstract type that represents a sequence, whose items can not be changed. +type, abstract, extends(Sequence) :: ImmutableSequence + +end type + +!> Type that corresponds to a Python list. +type, extends(MutableSequence) :: list + contains + procedure, private :: list_append_object + !> Append an item at the end of a list + generic, public :: append => list_append_object + + !> Creates a copy of a list + procedure, public :: copy => list_copy + !> Sorts the list. + procedure, public :: sort => list_sort + !> Reverses a list. + procedure, public :: reverse => list_reverse + !> Concatenates another list at the end of a list. + procedure, public :: add => list_add + + procedure, private :: list_insert_int32 + !> Inserts item at given index. + generic, public :: insert => list_insert_int32 + procedure, private :: list_delitem_int32 + !> Deletes item at given index from list. + generic, public :: delitem => list_delitem_int32 + procedure, private :: list_insert_int64 + !> Inserts item at given index. + generic, public :: insert => list_insert_int64 + procedure, private :: list_delitem_int64 + !> Deletes item at given index from list. + generic, public :: delitem => list_delitem_int64 + + procedure, private :: list_append_int32 + !> Append an item at the end of a list + generic, public :: append => list_append_int32 + procedure, private :: list_append_int64 + !> Append an item at the end of a list + generic, public :: append => list_append_int64 + procedure, private :: list_append_real32 + !> Append an item at the end of a list + generic, public :: append => list_append_real32 + procedure, private :: list_append_real64 + !> Append an item at the end of a list + generic, public :: append => list_append_real64 + procedure, private :: list_append_complex_real32 + !> Append an item at the end of a list + generic, public :: append => list_append_complex_real32 + procedure, private :: list_append_complex_real64 + !> Append an item at the end of a list + generic, public :: append => list_append_complex_real64 + procedure, private :: list_append_logical + !> Append an item at the end of a list + generic, public :: append => list_append_logical + procedure, private :: list_append_char_1d + !> Append an item at the end of a list + generic, public :: append => list_append_char_1d + procedure, private :: list_append_chars + !> Append an item at the end of a list + generic, public :: append => list_append_chars + +end type + +!> Abstract type that represents a datastructure that maps keys to values. +type, abstract, extends(object) :: Mapping + contains + procedure, private :: mapping_getitem_object_object + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_object_object + procedure, private :: mapping_setitem_object_object + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_object_object + procedure, private :: mapping_delitem_object + !> Delete key-value pair with given key. + generic, public :: delitem => mapping_delitem_object + + procedure, private :: mapping_getitem_int32_object + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int32_object + procedure, private :: mapping_setitem_int32_object + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int32_object + !> Delete key-value pair with given key. + procedure, private :: mapping_delitem_int32 + generic, public :: delitem => mapping_delitem_int32 + procedure, private :: mapping_getitem_int32_int32 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int32_int32 + procedure, private :: mapping_setitem_int32_int32 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int32_int32 + procedure, private :: mapping_getitem_int32_int64 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int32_int64 + procedure, private :: mapping_setitem_int32_int64 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int32_int64 + procedure, private :: mapping_getitem_int32_real32 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int32_real32 + procedure, private :: mapping_setitem_int32_real32 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int32_real32 + procedure, private :: mapping_getitem_int32_real64 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int32_real64 + procedure, private :: mapping_setitem_int32_real64 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int32_real64 + procedure, private :: mapping_getitem_int32_complex_real32 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int32_complex_real32 + procedure, private :: mapping_setitem_int32_complex_real32 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int32_complex_real32 + procedure, private :: mapping_getitem_int32_complex_real64 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int32_complex_real64 + procedure, private :: mapping_setitem_int32_complex_real64 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int32_complex_real64 + procedure, private :: mapping_getitem_int32_logical + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int32_logical + procedure, private :: mapping_setitem_int32_logical + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int32_logical + procedure, private :: mapping_getitem_int32_char_1d + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int32_char_1d + procedure, private :: mapping_setitem_int32_char_1d + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int32_char_1d + procedure, private :: mapping_getitem_int32_chars + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int32_chars + procedure, private :: mapping_setitem_int32_chars + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int32_chars + procedure, private :: mapping_getitem_int64_object + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int64_object + procedure, private :: mapping_setitem_int64_object + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int64_object + !> Delete key-value pair with given key. + procedure, private :: mapping_delitem_int64 + generic, public :: delitem => mapping_delitem_int64 + procedure, private :: mapping_getitem_int64_int32 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int64_int32 + procedure, private :: mapping_setitem_int64_int32 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int64_int32 + procedure, private :: mapping_getitem_int64_int64 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int64_int64 + procedure, private :: mapping_setitem_int64_int64 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int64_int64 + procedure, private :: mapping_getitem_int64_real32 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int64_real32 + procedure, private :: mapping_setitem_int64_real32 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int64_real32 + procedure, private :: mapping_getitem_int64_real64 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int64_real64 + procedure, private :: mapping_setitem_int64_real64 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int64_real64 + procedure, private :: mapping_getitem_int64_complex_real32 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int64_complex_real32 + procedure, private :: mapping_setitem_int64_complex_real32 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int64_complex_real32 + procedure, private :: mapping_getitem_int64_complex_real64 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int64_complex_real64 + procedure, private :: mapping_setitem_int64_complex_real64 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int64_complex_real64 + procedure, private :: mapping_getitem_int64_logical + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int64_logical + procedure, private :: mapping_setitem_int64_logical + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int64_logical + procedure, private :: mapping_getitem_int64_char_1d + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int64_char_1d + procedure, private :: mapping_setitem_int64_char_1d + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int64_char_1d + procedure, private :: mapping_getitem_int64_chars + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_int64_chars + procedure, private :: mapping_setitem_int64_chars + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_int64_chars + procedure, private :: mapping_getitem_chars_object + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_chars_object + procedure, private :: mapping_setitem_chars_object + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_chars_object + !> Delete key-value pair with given key. + procedure, private :: mapping_delitem_chars + generic, public :: delitem => mapping_delitem_chars + procedure, private :: mapping_getitem_chars_int32 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_chars_int32 + procedure, private :: mapping_setitem_chars_int32 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_chars_int32 + procedure, private :: mapping_getitem_chars_int64 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_chars_int64 + procedure, private :: mapping_setitem_chars_int64 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_chars_int64 + procedure, private :: mapping_getitem_chars_real32 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_chars_real32 + procedure, private :: mapping_setitem_chars_real32 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_chars_real32 + procedure, private :: mapping_getitem_chars_real64 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_chars_real64 + procedure, private :: mapping_setitem_chars_real64 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_chars_real64 + procedure, private :: mapping_getitem_chars_complex_real32 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_chars_complex_real32 + procedure, private :: mapping_setitem_chars_complex_real32 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_chars_complex_real32 + procedure, private :: mapping_getitem_chars_complex_real64 + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_chars_complex_real64 + procedure, private :: mapping_setitem_chars_complex_real64 + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_chars_complex_real64 + procedure, private :: mapping_getitem_chars_logical + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_chars_logical + procedure, private :: mapping_setitem_chars_logical + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_chars_logical + procedure, private :: mapping_getitem_chars_char_1d + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_chars_char_1d + procedure, private :: mapping_setitem_chars_char_1d + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_chars_char_1d + procedure, private :: mapping_getitem_chars_chars + !> Get value at a given key. KeyError if key does not exist + generic, public :: getitem => mapping_getitem_chars_chars + procedure, private :: mapping_setitem_chars_chars + !> Inserts value at given key. Sets value if key already exists. + generic, public :: setitem => mapping_setitem_chars_chars + + procedure, private :: mapping_len_int32 + !> Get number of key-value pairs. + generic, public :: len => mapping_len_int32 + procedure, private :: mapping_len_int64 + !> Get number of key-value pairs. + generic, public :: len => mapping_len_int64 + + !> Checks if key is contained in datastructure. + procedure, public :: mapping_contains + +end type + +type, extends(Mapping) :: dict + contains + !> Removes all key-value pairs from dictionary. + procedure, public :: clear => dict_clear + !> Creates a copy of dict + procedure, public :: copy => dict_copy + !> Creates a list of a dict's keys + procedure, public :: keys => dict_keys + !> Creates a list of a dict's key-value pairs. + procedure, public :: items => dict_items + !> Creates a list of a dict's values + procedure, public :: values => dict_values + + procedure, private :: dict_get_object_object + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_object_object + procedure, private :: dict_get_int32_object + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int32_object + procedure, private :: dict_get_int32_int32 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int32_int32 + procedure, private :: dict_get_int32_int64 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int32_int64 + procedure, private :: dict_get_int32_real32 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int32_real32 + procedure, private :: dict_get_int32_real64 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int32_real64 + procedure, private :: dict_get_int32_complex_real32 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int32_complex_real32 + procedure, private :: dict_get_int32_complex_real64 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int32_complex_real64 + procedure, private :: dict_get_int32_logical + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int32_logical + procedure, private :: dict_get_int32_char_1d + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int32_char_1d + procedure, private :: dict_get_int32_chars + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int32_chars + procedure, private :: dict_get_int64_object + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int64_object + procedure, private :: dict_get_int64_int32 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int64_int32 + procedure, private :: dict_get_int64_int64 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int64_int64 + procedure, private :: dict_get_int64_real32 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int64_real32 + procedure, private :: dict_get_int64_real64 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int64_real64 + procedure, private :: dict_get_int64_complex_real32 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int64_complex_real32 + procedure, private :: dict_get_int64_complex_real64 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int64_complex_real64 + procedure, private :: dict_get_int64_logical + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int64_logical + procedure, private :: dict_get_int64_char_1d + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int64_char_1d + procedure, private :: dict_get_int64_chars + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_int64_chars + procedure, private :: dict_get_chars_object + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_chars_object + procedure, private :: dict_get_chars_int32 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_chars_int32 + procedure, private :: dict_get_chars_int64 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_chars_int64 + procedure, private :: dict_get_chars_real32 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_chars_real32 + procedure, private :: dict_get_chars_real64 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_chars_real64 + procedure, private :: dict_get_chars_complex_real32 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_chars_complex_real32 + procedure, private :: dict_get_chars_complex_real64 + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_chars_complex_real64 + procedure, private :: dict_get_chars_logical + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_chars_logical + procedure, private :: dict_get_chars_char_1d + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_chars_char_1d + procedure, private :: dict_get_chars_chars + !> Get value at a given key. If key does not exist, return a default value. + generic, public :: get => dict_get_chars_chars + + !> Get value at a given key. If key does not exist, set value at key to default value and return default. + procedure, public :: setdefault => dict_setdefault_object_object +end type + +!> Type that corresponds to a Python tuple. Create with tuple_create. +type, extends(ImmutableSequence) :: tuple + contains + procedure, private :: tuple_setitem_int32_object + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int32_object + procedure, private :: tuple_setitem_int32_int32 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int32_int32 + procedure, private :: tuple_setitem_int32_int64 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int32_int64 + procedure, private :: tuple_setitem_int32_real32 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int32_real32 + procedure, private :: tuple_setitem_int32_real64 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int32_real64 + procedure, private :: tuple_setitem_int32_complex_real32 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int32_complex_real32 + procedure, private :: tuple_setitem_int32_complex_real64 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int32_complex_real64 + procedure, private :: tuple_setitem_int32_logical + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int32_logical + procedure, private :: tuple_setitem_int32_char_1d + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int32_char_1d + procedure, private :: tuple_setitem_int32_chars + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int32_chars + procedure, private :: tuple_setitem_int64_object + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int64_object + procedure, private :: tuple_setitem_int64_int32 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int64_int32 + procedure, private :: tuple_setitem_int64_int64 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int64_int64 + procedure, private :: tuple_setitem_int64_real32 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int64_real32 + procedure, private :: tuple_setitem_int64_real64 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int64_real64 + procedure, private :: tuple_setitem_int64_complex_real32 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int64_complex_real32 + procedure, private :: tuple_setitem_int64_complex_real64 + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int64_complex_real64 + procedure, private :: tuple_setitem_int64_logical + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int64_logical + procedure, private :: tuple_setitem_int64_char_1d + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int64_char_1d + procedure, private :: tuple_setitem_int64_chars + !> Sets item at given index. One must set all items before use of tuple. + generic, public :: setitem => tuple_setitem_int64_chars + + !> Concatenates tuples. + procedure, public :: add => tuple_add +end type + +!> Creates a tuple with a given number of items. +interface tuple_create + module procedure tuple_create_int32 + module procedure tuple_create_int64 + module procedure tuple_create_object +end interface + +!> Creates a list. Create as empty list or from other object. +interface list_create + module procedure list_create_empty + module procedure list_create_object +end interface + +!> Type corresponding to Python 'bytes'. +type, extends(ImmutableSequence) :: bytes + +end type + +!> Creates a bytes object from Fortran character string or character array. +interface bytes_create + module procedure bytes_create_chars + module procedure bytes_create_char_1d +end interface + +!> Type corresponding to Python 'str' - Python's string type. +type, extends(ImmutableSequence) :: str + +end type + +!> Creates a str object from Fortran character string or character array. +interface str_create + module procedure str_create_chars + module procedure str_create_char_1d + module procedure str_create_object +end interface + +!> Type corresponding to Python 2 'unicode' or Python 3 'str'. +type, extends(ImmutableSequence) :: unicode + +end type + +!> Creates a unicode string from Fortran character string or character array. +interface unicode_create + module procedure unicode_create_chars + module procedure unicode_create_char_1d +end interface + +!> Type representing a Python module +type, extends(object) :: module_py +end type + +!> Type representing Python's 'None'. Create with NoneType_create. +type, extends(object) :: NoneType +end type + +!> Interface to call a Python objects (methods or other callables) +!> Arguments (optional) have to be passed as tuple. +!> Keyword arguments (optional) have to be passed as dict. +interface call_py + module procedure call_py_attribute + module procedure call_py_object + module procedure call_py_object_nokwargs + module procedure call_py_object_noargs + module procedure call_py_object_only_kwargs +end interface + +!> Interface to call a Python objects (methods or other callables), ignoring the return value. +!> Arguments (optional) have to be passed as tuple. +!> Keyword arguments (optional) have to be passed as dict. +interface call_py_noret + module procedure call_py_noret_attribute + module procedure call_py_noret_object +end interface + +!> Creates a new reference to an object. Python equivalent: lhs = rhs +!> Do not forget to destroy lhs after use. +interface assign_py + module procedure assign_py_object + module procedure assign_py_list + module procedure assign_py_tuple + module procedure assign_py_dict + module procedure assign_py_ndarray + module procedure assign_py_type_py + module procedure assign_py_module_py + module procedure assign_py_NoneType +end interface + +! or extends MutableSequence? probably better as object since indexing is fancier than for a sequence? +!> Type that represents a Numpy array +type, extends(object) :: ndarray + contains + procedure, private :: get_data_int32_1d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_int32_1d + procedure, private :: get_data_int64_1d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_int64_1d + procedure, private :: get_data_real32_1d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_real32_1d + procedure, private :: get_data_real64_1d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_real64_1d + procedure, private :: get_data_complex_real32_1d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_complex_real32_1d + procedure, private :: get_data_complex_real64_1d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_complex_real64_1d + procedure, private :: get_data_int32_2d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_int32_2d + procedure, private :: get_data_int64_2d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_int64_2d + procedure, private :: get_data_real32_2d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_real32_2d + procedure, private :: get_data_real64_2d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_real64_2d + procedure, private :: get_data_complex_real32_2d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_complex_real32_2d + procedure, private :: get_data_complex_real64_2d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_complex_real64_2d + procedure, private :: get_data_int32_3d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_int32_3d + procedure, private :: get_data_int64_3d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_int64_3d + procedure, private :: get_data_real32_3d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_real32_3d + procedure, private :: get_data_real64_3d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_real64_3d + procedure, private :: get_data_complex_real32_3d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_complex_real32_3d + procedure, private :: get_data_complex_real64_3d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_complex_real64_3d + procedure, private :: get_data_int32_4d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_int32_4d + procedure, private :: get_data_int64_4d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_int64_4d + procedure, private :: get_data_real32_4d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_real32_4d + procedure, private :: get_data_real64_4d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_real64_4d + procedure, private :: get_data_complex_real32_4d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_complex_real32_4d + procedure, private :: get_data_complex_real64_4d + !> Retrieve a Fortran pointer to the array data. + generic, public :: get_data => get_data_complex_real64_4d + !> Transpose the array. + procedure, public :: transpose => ndarray_transpose + !> Create a copy (with its own data) of the ndarray + procedure, public :: copy => ndarray_copy + !> Checks if the array has Fortran or C storage order (contiguous array) + procedure, public :: is_ordered => ndarray_is_ordered + !> Get numpy.dtype type identifier of the array. Python equivalent: self.dtype.name + procedure, public :: get_dtype_name => ndarray_get_dtype_name + + procedure, private :: ndarray_ndim_int32 + procedure, private :: ndarray_ndim_int64 + !> Get dimension of array + generic, public :: ndim => ndarray_ndim_int32 + !> Get dimension of array + generic, public :: ndim => ndarray_ndim_int64 +end type + +!> Create a ndarray from a Fortran array. The ndarray will be a copy +!> of the Fortran array. +interface ndarray_create + module procedure ndarray_create_int32_1d + module procedure ndarray_create_int64_1d + module procedure ndarray_create_real32_1d + module procedure ndarray_create_real64_1d + module procedure ndarray_create_complex_real32_1d + module procedure ndarray_create_complex_real64_1d + module procedure ndarray_create_int32_2d + module procedure ndarray_create_int64_2d + module procedure ndarray_create_real32_2d + module procedure ndarray_create_real64_2d + module procedure ndarray_create_complex_real32_2d + module procedure ndarray_create_complex_real64_2d + module procedure ndarray_create_int32_3d + module procedure ndarray_create_int64_3d + module procedure ndarray_create_real32_3d + module procedure ndarray_create_real64_3d + module procedure ndarray_create_complex_real32_3d + module procedure ndarray_create_complex_real64_3d + module procedure ndarray_create_int32_4d + module procedure ndarray_create_int64_4d + module procedure ndarray_create_real32_4d + module procedure ndarray_create_real64_4d + module procedure ndarray_create_complex_real32_4d + module procedure ndarray_create_complex_real64_4d +end interface + +!> Create a ndarray wrapper for a Fortran array. NO copy is made, changes +!> to the Fortran array affect the ndarray and vice versa. +!> +!> Only pass contiguous Fortran arrays to this function. This is not checked! +!> +!> The lifetime of the Fortran array must be at least as long as the +!> ndarray is in use: beware of deallocation and compiler generated +!> temporary arrays. +!> +!> Since the Fortran array is used as underlying buffer for the ndarray, +!> it can be indirectly modified by changing the ndarray. To avoid bugs +!> related to certain compiler optimizations, declare the Fortran array +!> with the 'asynchronous' attribute. +interface ndarray_create_nocopy + module procedure ndarray_create_nocopy_int32_1d + module procedure ndarray_create_nocopy_int64_1d + module procedure ndarray_create_nocopy_real32_1d + module procedure ndarray_create_nocopy_real64_1d + module procedure ndarray_create_nocopy_complex_real32_1d + module procedure ndarray_create_nocopy_complex_real64_1d + module procedure ndarray_create_nocopy_int32_2d + module procedure ndarray_create_nocopy_int64_2d + module procedure ndarray_create_nocopy_real32_2d + module procedure ndarray_create_nocopy_real64_2d + module procedure ndarray_create_nocopy_complex_real32_2d + module procedure ndarray_create_nocopy_complex_real64_2d + module procedure ndarray_create_nocopy_int32_3d + module procedure ndarray_create_nocopy_int64_3d + module procedure ndarray_create_nocopy_real32_3d + module procedure ndarray_create_nocopy_real64_3d + module procedure ndarray_create_nocopy_complex_real32_3d + module procedure ndarray_create_nocopy_complex_real64_3d + module procedure ndarray_create_nocopy_int32_4d + module procedure ndarray_create_nocopy_int64_4d + module procedure ndarray_create_nocopy_real32_4d + module procedure ndarray_create_nocopy_real64_4d + module procedure ndarray_create_nocopy_complex_real32_4d + module procedure ndarray_create_nocopy_complex_real64_4d +end interface + +!> Creates an empty ndarray of given shape. Array contains uninitialised values. +interface ndarray_create_empty + module procedure ndarray_create_empty_aint32 + module procedure ndarray_create_empty_aint64 + module procedure ndarray_create_empty_int32 + module procedure ndarray_create_empty_int64 +end interface + +!> Creates a ndarray of zeroes. +interface ndarray_create_zeros + module procedure ndarray_create_zeros_aint32 + module procedure ndarray_create_zeros_aint64 + module procedure ndarray_create_zeros_int32 + module procedure ndarray_create_zeros_int64 +end interface + +!> Creates a ndarray of ones. +interface ndarray_create_ones + module procedure ndarray_create_ones_aint32 + module procedure ndarray_create_ones_aint64 + module procedure ndarray_create_ones_int32 + module procedure ndarray_create_ones_int64 +end interface + +!> Casts/Transforms between Fortran and Python datatypes +!> +!> Result is 1st argument to cast, object/scalar to cast 2nd argument +!> Use to cast/transform a Python [[object]] into a Fortran value +!> Use to cast/transform Fortran values into a Python [[object]] +!> and to cast an unspecific Python [[object]] into more specific objects, such +!> as [[list]], [[tuple]], [[dict]] +!> Fortran values can be scalars and character strings or character arrays +!> Fortran character strings are decoded as UTF-8 +!> Python strings are encoded as UTF-8 +!> +!> For casting to numerical Fortran scalars, there is an optional 3rd argument "strict" +!> for cast: if strict=.false. it will try to convert numerical values to the requested +!> datatype (default: strict=.true.). This is the same as using [[cast_nonstrict]]. +interface cast + module procedure cast_to_list + module procedure cast_to_dict + module procedure cast_to_tuple + module procedure cast_to_NoneType + module procedure cast_to_ndarray + module procedure cast_to_str + module procedure cast_to_bytes + module procedure cast_to_unicode + module procedure cast_to_object + + module procedure cast_to_char_1d + module procedure cast_to_chars + module procedure cast_from_char_1d + module procedure cast_from_chars + + module procedure cast_to_int32 + module procedure cast_to_int32_flex + module procedure cast_from_int32 + module procedure cast_to_int64 + module procedure cast_to_int64_flex + module procedure cast_from_int64 + module procedure cast_to_real32 + module procedure cast_to_real32_flex + module procedure cast_from_real32 + module procedure cast_to_real64 + module procedure cast_to_real64_flex + module procedure cast_from_real64 + module procedure cast_to_complex_real32 + module procedure cast_to_complex_real32_flex + module procedure cast_from_complex_real32 + module procedure cast_to_complex_real64 + module procedure cast_to_complex_real64_flex + module procedure cast_from_complex_real64 + module procedure cast_to_logical + module procedure cast_to_logical_flex + module procedure cast_from_logical +end interface + +!> Non-strict casts/transforms between Fortran and Python datatypes +!> +!> Result is 1st argument to cast, 2nd argument object/scalar to cast +!> +!> In contrast to [[cast]], cast_nonstrict tries to convert to the type specified +!> by the 1st argument even when there is no exact correspondence of types. +!> Non-strict cast might lead to loss of information (e. g. when casting +!> a float to an integer) or might need additional memory and time for +!> making a copy (e. g. casting a list to a tuple) +!> +!> Use to cast/transform a Python [[object]] into a Fortran value +!> and to cast an unspecific Python [[object]] into more specific objects, such +!> as [[list]] or [[tuple]], converting between types when necessary. +!> Fortran values can be scalars or character strings. +!> +!> Can be used to get the string representation of a Python object +!> as a Fortran character string. +!> Python strings are encoded as UTF-8 +interface cast_nonstrict + module procedure cast_nonstrict_to_list + module procedure cast_nonstrict_to_tuple + module procedure cast_nonstrict_to_str + + ! no cast_nonstrict_to_char_1d, because one can + ! not always return a pointer to a character buffer + + module procedure cast_nonstrict_to_chars + + module procedure cast_nonstrict_to_int32 + module procedure cast_nonstrict_to_int64 + module procedure cast_nonstrict_to_real32 + module procedure cast_nonstrict_to_real64 + module procedure cast_nonstrict_to_complex_real32 + module procedure cast_nonstrict_to_complex_real64 + module procedure cast_nonstrict_to_logical +end interface + +! Class objects that correspond to Python standard exceptions +type(type_py), public, save :: ArithmeticError +type(type_py), public, save :: AssertionError +type(type_py), public, save :: AttributeError +type(type_py), public, save :: BaseException +type(type_py), public, save :: BufferError +type(type_py), public, save :: BytesWarning +type(type_py), public, save :: DeprecationWarning +type(type_py), public, save :: EOFError +type(type_py), public, save :: EnvironmentError +type(type_py), public, save :: Exception +type(type_py), public, save :: FloatingPointError +type(type_py), public, save :: FutureWarning +type(type_py), public, save :: GeneratorExit +type(type_py), public, save :: IOError +type(type_py), public, save :: ImportError +type(type_py), public, save :: ImportWarning +type(type_py), public, save :: IndentationError +type(type_py), public, save :: IndexError +type(type_py), public, save :: KeyError +type(type_py), public, save :: KeyboardInterrupt +type(type_py), public, save :: LookupError +type(type_py), public, save :: MemoryError +type(type_py), public, save :: NameError +type(type_py), public, save :: NotImplementedError +type(type_py), public, save :: OSError +type(type_py), public, save :: OverflowError +type(type_py), public, save :: PendingDeprecationWarning +type(type_py), public, save :: ReferenceError +type(type_py), public, save :: RuntimeError +type(type_py), public, save :: RuntimeWarning +type(type_py), public, save :: StandardError +type(type_py), public, save :: StopIteration +type(type_py), public, save :: SyntaxError +type(type_py), public, save :: SyntaxWarning +type(type_py), public, save :: SystemError +type(type_py), public, save :: SystemExit +type(type_py), public, save :: TabError +type(type_py), public, save :: TypeError +type(type_py), public, save :: UnboundLocalError +type(type_py), public, save :: UnicodeDecodeError +type(type_py), public, save :: UnicodeEncodeError +type(type_py), public, save :: UnicodeError +type(type_py), public, save :: UnicodeTranslateError +type(type_py), public, save :: UnicodeWarning +type(type_py), public, save :: UserWarning +type(type_py), public, save :: ValueError +type(type_py), public, save :: Warning +type(type_py), public, save :: ZeroDivisionError + +! Types needed for writing a Python extension +! For extensions one needs exactly one of PythonMethodTable and PythonModule at Fortran module level + +!> just a helper type, not public +type PythonMethodTableStrings + character(kind=C_CHAR, len=:), pointer :: doc_string + character(kind=C_CHAR, len=:), pointer :: method_name +end type + +!> Only used for writing Python extension modules. Datastructure to hold table of methods of your Python extension module. +!> Put exactly one instance at Fortran module level. +!> +!> Python 3: initialise and configure in PyInit_*module name* function with bind(c, name="PyInit_*module_name*") +!> attribute and type(c_ptr) return value. +!> Python 2: initialise in init*module name* subroutine with bind(c) attribute +!> +!> Pass the configured PythonMethodTable to PythonModule%init +type PythonMethodTable +private + type(PyMethodDef), dimension(:), pointer :: methods + type(PythonMethodTableStrings), dimension(:), allocatable :: strings + integer :: num_methods + integer :: method_count +contains + !> Initialises the method table. Call in PyInit_*module name* (Py3) / init*module name* (Py2) + procedure, public :: init => PythonMethodTable_init + !> Adds a method to your Python module + procedure, public :: add_method => PythonMethodTable_add_method + !> Used only internally. Gets type(c_ptr) to method table. + procedure, public :: get_method_table => PythonMethodTable_get +end type + +!> Only used for writing Python extension modules. Datastructure to hold information about +!> your Python extension module. Put exactly one instance at Fortran module level. +!> +!> Python 3: initialise and configure in PyInit_ function with bind(c, name="PyInit_") +!> attribute and type(c_ptr) return value. +!> +!> Python 2: initialise in init subroutine with bind(c) attribute +type PythonModule +private + type(PyModuleDef), pointer :: module_def + character(kind=C_CHAR, len=:), pointer :: doc_string + character(kind=C_CHAR, len=:), pointer :: module_name + type(c_ptr) :: module_ptr +contains + !> Initialises the PythonModule with a PythonMethod table. + !> + !> Python 3: the return value must be returned by PyInit_*module name* + !> + !> Python 2: call in init*module name*, ignore return value + procedure, public :: init => PythonModule_init + !> Adds a Python object to the module that can be accessed by + !> my_module.the_name_of_object_added + !> Useful to add constants to a Python module + procedure, public :: add_object => PythonModule_add_object +end type + +CONTAINS + +!> Initialisation of forpy module. Must be called before using forpy. +function forpy_initialize(use_numpy) result(ierror) + !> Set to .false., if you do not need the array features of forpy powered by numpy. (Default: .true.) + logical, optional, intent(in) :: use_numpy + integer(kind=C_INT) :: ierror + + logical :: numpy_flag + + if (present(use_numpy)) then + numpy_flag = use_numpy + else + numpy_flag = .true. + endif + ierror = 1_C_INT + if (Py_IsInitialized() == 0_C_INT) then + call Py_Initialize() + endif + + ierror = 0_C_INT + if (global_forpy_initialized == 0) then + ierror = forpy_initialize_forpy_globals() + if (ierror == 0_C_INT) then + global_forpy_initialized = 1 + endif + endif + + if (ierror == 0_C_INT .and. numpy_flag & + .and. .not. c_associated(global_numpy_mod)) then + ierror = forpy_initialize_numpy() + endif +end function + +function forpy_initialize_forpy_globals() result(ierror) + integer(kind=C_INT) :: ierror + + ! Initialise Python's None object + ierror = forpy_initialize_none() + if (ierror /= 0) then + return + endif + + ierror = forpy_initialize_float() + if (ierror /= 0) then + return + endif + + ierror = forpy_initialize_complex() + if (ierror /= 0) then + return + endif + + ierror = forpy_initialize_bool() + if (ierror /= 0) then + return + endif + + ierror = forpy_initialize_unicode() + if (ierror /= 0) then + return + endif + + ierror = forpy_initialize_exceptions() + if (ierror /= 0) then + return + endif + + ierror = forpy_initialize_sys_argv() + if (ierror /= 0) then + return + endif +end function + +!> Sets sys.argv = [''], since some 3rd party Python modules require +!> sys.argv[0] - before Python 3.8 sys.argv does not exist in embedded Python, +!> see https://bugs.python.org/issue32573 +function forpy_initialize_sys_argv() result(ierror) + integer(kind=C_INT) :: ierror + + ! there also exist C-API functions to set sys.argv, but they involve wchar_t + ! which iso_c_binding does not support and that has platform dep. size + ierror = PyRun_SimpleString("import sys" // C_NEW_LINE // & + "if not hasattr(sys, 'argv') or sys.argv==[]:" // C_NEW_LINE // & + " sys.argv=['']" // C_NEW_LINE // C_NULL_CHAR) +end function + +function forpy_initialize_numpy() result(ierror) + integer(kind=C_INT) :: ierror + + type(c_ptr) :: asarray_str + type(c_ptr) :: ndarray_str + + ! Initialisation of Numpy + global_numpy_mod = PyImport_ImportModule(C_CHAR_"numpy" // C_NULL_CHAR) + if (.not. c_associated(global_numpy_mod)) then + ierror = NO_NUMPY_ERROR + call err_clear + return + else + + ! TODO: exception checks? + ierror = box_value(asarray_str, "asarray") + + if (.not. c_associated(asarray_str)) then + ierror = NO_NUMPY_ERROR + call err_clear + return + else + global_numpy_asarray_method = PyObject_GetAttr(global_numpy_mod, asarray_str) + call Py_Decref(asarray_str) + + if (.not. c_associated(global_numpy_asarray_method)) then + ierror = NO_NUMPY_ERROR ! Something's wrong with numpy... but might use Python without numpy + call err_clear + endif + endif + endif + + ! Get the numpy.ndarray type-object + if (ierror == 0) then + ierror = box_value(ndarray_str, "ndarray") + + if (ierror /= 0) then + return + endif + + global_numpy_ndarray_typeobj = PyObject_GetAttr(global_numpy_mod, ndarray_str) + call Py_Decref(ndarray_str) + + if (.not. c_associated(global_numpy_asarray_method)) then + ierror = NO_NUMPY_ERROR ! No Numpy... + call err_clear + endif + + endif + +end function + +! sets up Python's None +function forpy_initialize_none() result(ierror) + integer(kind=C_INT) :: ierror + + type(list) :: li + type(tuple) :: args + type(dict) :: kwargs + type(object) :: none_obj + + ! A bit hacky: use return value of the following python expression + ! to get pointer to the singleton None-object (_Py_NoneStruct): + ! The expression is: [].sort() + + ierror = list_create(li) + if (ierror /= 0) then + return + endif + + ierror = tuple_create(args, 0) + if (ierror /= 0) then + call li%destroy() + return + endif + + ierror = dict_create(kwargs) + if (ierror /= 0) then + call li%destroy() + call args%destroy() + return + endif + + ierror = call_py_attribute(none_obj, li, "sort", args, kwargs) + + if (ierror == 0 .and. c_associated(none_obj%py_object)) then + global_Py_NoneStruct_ptr = none_obj%py_object + call none_obj%destroy() + endif + + call li%destroy() + call args%destroy() + call kwargs%destroy() + + ierror = 0_C_INT +end function + +! Get pointer to "float"-type object +function forpy_initialize_float() result(ierror) + integer(kind=C_INT) :: ierror + + type(c_ptr) :: a_float + type(PyObject), pointer :: ptr + + a_float = PyFloat_FromDouble(1.0_C_DOUBLE) + + if (.not. c_associated(a_float)) then + ierror = EXCEPTION_ERROR + return + endif + + call c_f_pointer(a_float, ptr) + global_pyfloat_type_ptr = ptr%ob_type + call Py_DecRef(a_float) + ierror = 0_C_INT +end function + +! Get pointer to "complex"-type object +! Note: floats are not complex in Python +function forpy_initialize_complex() result(ierror) + integer(kind=C_INT) :: ierror + + type(c_ptr) :: a_complex + type(PyObject), pointer :: ptr + + a_complex = PyComplex_FromDoubles(1.0_C_DOUBLE, 1.0_C_DOUBLE) + + if (.not. c_associated(a_complex)) then + ierror = EXCEPTION_ERROR + return + endif + + call c_f_pointer(a_complex, ptr) + global_pycomplex_type_ptr = ptr%ob_type + call Py_DecRef(a_complex) + ierror = 0_C_INT +end function + +! Get pointer to "unicode"-type object +function forpy_initialize_unicode() result(ierror) + integer(kind=C_INT) :: ierror + + type(c_ptr) :: a_unicode + type(PyObject), pointer :: ptr + + character(kind=C_CHAR), dimension(1) :: a + character(kind=C_CHAR), dimension(7) :: b + + a = [C_NULL_CHAR] + b = ['s','t','r','i','c','t', C_NULL_CHAR] + + ! fix for PGI compiler: pgi does not like if a and b are + ! string literals in this function call + a_unicode = PyUnicode_DecodeUTF8(a, 0_PY_SSIZE_T_KIND, b) + + if (.not. c_associated(a_unicode)) then + ierror = EXCEPTION_ERROR + return + endif + + call c_f_pointer(a_unicode, ptr) + global_pyunicode_type_ptr = ptr%ob_type + call Py_DecRef(a_unicode) + ierror = 0_C_INT +end function + +! Get pointer to "bool"-type object and the singletons Py_True and Py_False +function forpy_initialize_bool() result(ierror) + integer(kind=C_INT) :: ierror + + type(c_ptr) :: a_bool + type(PyObject), pointer :: ptr + + a_bool = PyBool_FromLong(0_C_LONG) + + if (.not. c_associated(a_bool)) then + ierror = EXCEPTION_ERROR + return + endif + + call c_f_pointer(a_bool, ptr) + global_pybool_type_ptr = ptr%ob_type + global_Py_FalseStruct_ptr = a_bool + call Py_DecRef(a_bool) + + a_bool = PyBool_FromLong(1_C_LONG) + + if (.not. c_associated(a_bool)) then + ierror = EXCEPTION_ERROR + return + endif + + global_Py_TrueStruct_ptr = a_bool + call Py_DecRef(a_bool) + + ierror = 0_C_INT +end function + +! initialise Python standard exceptions +function forpy_initialize_exceptions() result(ierror) + integer(kind=C_INT) :: ierror + + type(c_ptr) :: tmp + type(c_ptr) :: builtin_dict + + ierror = 0_C_INT + + builtin_dict = PyEval_GetBuiltins() + if (.not. c_associated(builtin_dict)) then + ierror = 1_C_INT + return + endif + + tmp = PyDict_GetItemString(builtin_dict, "ArithmeticError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + ArithmeticError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "AssertionError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + AssertionError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "AttributeError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + AttributeError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "BaseException" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + BaseException%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "BufferError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + BufferError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "BytesWarning" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + BytesWarning%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "DeprecationWarning" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + DeprecationWarning%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "EOFError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + EOFError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "EnvironmentError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + EnvironmentError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "Exception" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + Exception%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "FloatingPointError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + FloatingPointError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "FutureWarning" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + FutureWarning%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "GeneratorExit" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + GeneratorExit%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "IOError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + IOError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "ImportError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + ImportError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "ImportWarning" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + ImportWarning%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "IndentationError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + IndentationError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "IndexError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + IndexError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "KeyError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + KeyError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "KeyboardInterrupt" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + KeyboardInterrupt%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "LookupError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + LookupError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "MemoryError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + MemoryError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "NameError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + NameError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "NotImplementedError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + NotImplementedError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "OSError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + OSError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "OverflowError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + OverflowError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "PendingDeprecationWarning" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + PendingDeprecationWarning%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "ReferenceError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + ReferenceError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "RuntimeError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + RuntimeError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "RuntimeWarning" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + RuntimeWarning%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "StandardError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + StandardError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "StopIteration" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + StopIteration%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "SyntaxError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + SyntaxError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "SyntaxWarning" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + SyntaxWarning%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "SystemError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + SystemError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "SystemExit" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + SystemExit%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "TabError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + TabError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "TypeError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + TypeError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "UnboundLocalError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + UnboundLocalError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "UnicodeDecodeError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + UnicodeDecodeError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "UnicodeEncodeError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + UnicodeEncodeError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "UnicodeError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + UnicodeError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "UnicodeTranslateError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + UnicodeTranslateError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "UnicodeWarning" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + UnicodeWarning%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "UserWarning" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + UserWarning%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "ValueError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + ValueError%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "Warning" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + Warning%py_object = tmp + tmp = PyDict_GetItemString(builtin_dict, "ZeroDivisionError" // C_NULL_CHAR) + if (.not. c_associated(tmp)) then; call PyErr_Clear(); endif + ZeroDivisionError%py_object = tmp +end function + +!> Frees resources used by Python interpreter. Call when finished using forpy. +subroutine forpy_finalize() + global_forpy_initialized = 0 + call Py_Decref(global_numpy_asarray_method) + call Py_Decref(global_numpy_mod) + global_numpy_asarray_method = C_NULL_PTR + global_numpy_mod = C_NULL_PTR + + call Py_Finalize() +end subroutine + + +!------------------------------------------------------------------------------------- +! Functions to check type +!> Checks if object is a Python long. +logical function is_long(obj) + !> The object to check. + class(object), intent(in) :: obj + + is_long = (check_tp_flags(obj%py_object, ishft(1_C_LONG, 24)) /= 0) +end function + +!> Checks if object is a Python list. +logical function is_list(obj) + !> The object to check. + class(object), intent(in) :: obj + + is_list = (check_tp_flags(obj%py_object, ishft(1_C_LONG, 25)) /= 0) +end function + +!> Checks if object is a Python tuple. +logical function is_tuple(obj) + !> The object to check. + class(object), intent(in) :: obj + + is_tuple = (check_tp_flags(obj%py_object, ishft(1_C_LONG, 26)) /= 0) +end function + +!> Checks if object is a Python bytes. +logical function is_bytes(obj) + !> The object to check. + class(object), intent(in) :: obj + + is_bytes = (check_tp_flags(obj%py_object, ishft(1_C_LONG, 27)) /= 0) +end function + +!> Checks if object is a Python dict. +logical function is_dict(obj) + !> The object to check. + class(object), intent(in) :: obj + + is_dict = (check_tp_flags(obj%py_object, ishft(1_C_LONG, 29)) /= 0) +end function + + +!> Checks if object is a Python float. +logical function is_float(obj) + !> The object to check. + class(object), intent(in) :: obj + type(PyObject), pointer :: obj_ptr + + if (.not. (c_associated(obj%py_object) .and. c_associated(global_pyfloat_type_ptr))) then + is_float = .false. + return + endif + + call c_f_pointer(obj%py_object, obj_ptr) + is_float = c_associated(global_pyfloat_type_ptr, obj_ptr%ob_type) + if (.not. is_float) then + is_float = (PyType_IsSubtype(obj_ptr%ob_type, global_pyfloat_type_ptr) /= 0) ! Check if subtype + endif +end function + +!> Checks if object is a Python complex. +logical function is_complex(obj) + !> The object to check. + class(object), intent(in) :: obj + type(PyObject), pointer :: obj_ptr + + if (.not. (c_associated(obj%py_object) .and. c_associated(global_pycomplex_type_ptr))) then + is_complex = .false. + return + endif + + call c_f_pointer(obj%py_object, obj_ptr) + is_complex = c_associated(global_pycomplex_type_ptr, obj_ptr%ob_type) + if (.not. is_complex) then + is_complex = (PyType_IsSubtype(obj_ptr%ob_type, global_pycomplex_type_ptr) /= 0) ! Check if subtype + endif +end function + +!> Checks if object is a Python bool. +logical function is_bool(obj) + !> The object to check. + class(object), intent(in) :: obj + type(PyObject), pointer :: obj_ptr + + if (.not. (c_associated(obj%py_object) .and. c_associated(global_pybool_type_ptr))) then + is_bool = .false. + return + endif + + call c_f_pointer(obj%py_object, obj_ptr) + is_bool = c_associated(global_pybool_type_ptr, obj_ptr%ob_type) + if (.not. is_bool) then + is_bool = (PyType_IsSubtype(obj_ptr%ob_type, global_pybool_type_ptr) /= 0) ! Check if subtype + endif +end function + +!> Checks if object is a Python unicode. +logical function is_unicode(obj) + !> The object to check. + class(object), intent(in) :: obj + type(PyObject), pointer :: obj_ptr + + if (.not. (c_associated(obj%py_object) .and. c_associated(global_pyunicode_type_ptr))) then + is_unicode = .false. + return + endif + + call c_f_pointer(obj%py_object, obj_ptr) + is_unicode = c_associated(global_pyunicode_type_ptr, obj_ptr%ob_type) + if (.not. is_unicode) then + is_unicode = (PyType_IsSubtype(obj_ptr%ob_type, global_pyunicode_type_ptr) /= 0) ! Check if subtype + endif +end function + + +#ifdef PYTHON2 +logical function is_short_int(obj) + class(object), intent(in) :: obj + + is_short_int = (check_tp_flags(obj%py_object, ishft(1_C_LONG, 23)) /= 0) +end function + +!> Checks if object is of integer Python type ('int' OR 'long') +logical function is_int(obj) + !> The object to check. + class(object), intent(in) :: obj + + is_int = is_short_int(obj) + if (.not. is_int) then + is_int = is_long(obj) + endif +end function +#endif + +#ifndef PYTHON2 +!> Checks if object is a Python int +logical function is_int(obj) + !> The object to check. + class(object), intent(in) :: obj + + is_int = is_long(obj) +end function +#endif + +!> Checks if object is a Python str +logical function is_str(obj) + !> The object to check. + class(object), intent(in) :: obj +#ifdef PYTHON2 + is_str = is_bytes(obj) +#else + is_str = is_unicode(obj) +#endif +end function + +!> Checks if object is a Python None. +logical function is_none(obj) + !> The object to check. + class(object), intent(in) :: obj + + is_none = c_associated(obj%py_object) .and. c_associated(global_Py_NoneStruct_ptr, obj%py_object) +end function + +!> Returns true if object is a null-pointer internally. Object is not properly initialised then. +logical function is_null(obj) + !> The object to check. + class(object), intent(in) :: obj + + is_null = (.not. c_associated(obj%py_object)) +end function + +!> Checks if object is a Numpy array. +logical function is_ndarray(obj) + !> The object to check. + class(object), intent(in) :: obj + + integer(kind=C_INT) :: res + type(c_ptr) :: err_obj + + if (.not. c_associated(global_numpy_ndarray_typeobj)) then + is_ndarray = .false. + return + endif + + res = PyObject_IsInstance(obj%py_object, global_numpy_ndarray_typeobj) + + ! if res==-1 then exception is set by PyObject_IsInstance + ! clear the exception and return false + if (res == -1_C_INT) then + is_ndarray = .false. + err_obj = PyErr_Occurred() + if (c_associated(err_obj)) then + call PyErr_Clear() + endif + return + endif + + is_ndarray = (res == 1) +end function + +!> Helper for type checks +function check_tp_flags(py_obj, mask) result(res) + type(c_ptr), intent(in) :: py_obj + integer(kind=C_LONG), intent(in) :: mask + integer(kind=C_LONG) :: res + + type(PyObject), pointer :: obj_ptr + type(PyTypeObject), pointer :: type_ptr + + call c_f_pointer(py_obj, obj_ptr) + call c_f_pointer(obj_ptr%ob_type, type_ptr) + + res = iand(type_ptr%tp_flags, mask) +end function + +!> Creates an empty list. Python equivalent: r = [] +function list_create_empty(r) result(ierror) + !> the freshly created empty list + type(list), intent(out) :: r + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + r%py_object = PyList_New(0_PY_SSIZE_T_KIND) + ierror = 0_C_INT + + if (.not. c_associated(r%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +!> Creates a list from given object if possible. Python equivalent: r = list(obj) +function list_create_object(r, obj) result(ierror) + !> the freshly created list + type(list), intent(out) :: r + !> object to create list from + class(object), intent(in) :: obj + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + r%py_object = PySequence_List(obj%py_object) + + if (.not. c_associated(r%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +!> Creates a tuple with a given number of elements +function tuple_create_int32(r, len) result(ierror) + !> the freshly created tuple + type(tuple), intent(out) :: r + !> Number of items in tuple + integer(kind=int32), intent(in) :: len + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: tmp + + tmp = int(len, PY_SSIZE_T_KIND) + r%py_object = PyTuple_New(tmp) + ierror = 0_C_INT + + if (.not. c_associated(r%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +!> Creates a tuple with a given number of elements +function tuple_create_int64(r, len) result(ierror) + !> the freshly created tuple + type(tuple), intent(out) :: r + !> Number of items in tuple + integer(kind=int64), intent(in) :: len + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: tmp + + tmp = int(len, PY_SSIZE_T_KIND) + r%py_object = PyTuple_New(tmp) + ierror = 0_C_INT + + if (.not. c_associated(r%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + + +function tuple_create_object(r, obj) result(ierror) + !> the created tuple + type(tuple), intent(out) :: r + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + r%py_object = PySequence_Tuple(obj%py_object) + + if (.not. c_associated(r%py_object)) then + ierror = EXCEPTION_ERROR + endif + +end function + +!> Creates a Python None. +function NoneType_create(r) result(ierror) + !> The created None + type(NoneType), intent(out) :: r + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + r%py_object = global_Py_NoneStruct_ptr + call Py_IncRef(global_Py_NoneStruct_ptr) + ierror = 0_C_INT + +end function + +!> Creates an empty Python dictionary. Python: r = {} +function dict_create(r) result(ierror) + !> The created empty dict + type(dict), intent(out) :: r + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + r%py_object = PyDict_New() + ierror = 0_C_INT + + if (.not. c_associated(r%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +subroutine dict_clear(self) + class(dict), intent(inout) :: self + call PyDict_Clear(self%py_object) +end subroutine + +function dict_copy(self, dest) result(ierror) + class(dict), intent(in) :: self + type(dict), intent(out) :: dest + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + dest%py_object = PyDict_Copy(self%py_object) + if (.not. c_associated(dest%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function dict_keys(self, keys) result(ierror) + class(dict), intent(in) :: self + type(list), intent(out) :: keys + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + keys%py_object = PyDict_Keys(self%py_object) + if (.not. c_associated(keys%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function dict_items(self, items) result(ierror) + class(dict), intent(in) :: self + type(list), intent(out) :: items + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + items%py_object = PyDict_Items(self%py_object) + if (.not. c_associated(items%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function dict_values(self, values) result(ierror) + class(dict), intent(in) :: self + type(list), intent(out) :: values + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + values%py_object = PyDict_Values(self%py_object) + if (.not. c_associated(values%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function list_append_object(self, item) result(ierror) + class(list), intent(inout) :: self + class(object), intent(in) :: item + integer(kind=C_INT) :: ierror + + ierror = PyList_Append(self%py_object, item%py_object) +end function + +function list_append_int32(self, item) result(ierror) + class(list), intent(inout) :: self + integer(kind=int32), intent(in) :: item + integer(kind=C_INT) :: ierror + + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + + if (ierror == 0_C_INT) then + ierror = PyList_Append(self%py_object, item_py) + call Py_DecRef(item_py) + endif +end function + +function list_append_int64(self, item) result(ierror) + class(list), intent(inout) :: self + integer(kind=int64), intent(in) :: item + integer(kind=C_INT) :: ierror + + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + + if (ierror == 0_C_INT) then + ierror = PyList_Append(self%py_object, item_py) + call Py_DecRef(item_py) + endif +end function + +function list_append_real32(self, item) result(ierror) + class(list), intent(inout) :: self + real(kind=real32), intent(in) :: item + integer(kind=C_INT) :: ierror + + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + + if (ierror == 0_C_INT) then + ierror = PyList_Append(self%py_object, item_py) + call Py_DecRef(item_py) + endif +end function + +function list_append_real64(self, item) result(ierror) + class(list), intent(inout) :: self + real(kind=real64), intent(in) :: item + integer(kind=C_INT) :: ierror + + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + + if (ierror == 0_C_INT) then + ierror = PyList_Append(self%py_object, item_py) + call Py_DecRef(item_py) + endif +end function + +function list_append_complex_real32(self, item) result(ierror) + class(list), intent(inout) :: self + complex(kind=real32), intent(in) :: item + integer(kind=C_INT) :: ierror + + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + + if (ierror == 0_C_INT) then + ierror = PyList_Append(self%py_object, item_py) + call Py_DecRef(item_py) + endif +end function + +function list_append_complex_real64(self, item) result(ierror) + class(list), intent(inout) :: self + complex(kind=real64), intent(in) :: item + integer(kind=C_INT) :: ierror + + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + + if (ierror == 0_C_INT) then + ierror = PyList_Append(self%py_object, item_py) + call Py_DecRef(item_py) + endif +end function + +function list_append_logical(self, item) result(ierror) + class(list), intent(inout) :: self + logical, intent(in) :: item + integer(kind=C_INT) :: ierror + + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + + if (ierror == 0_C_INT) then + ierror = PyList_Append(self%py_object, item_py) + call Py_DecRef(item_py) + endif +end function + +function list_append_char_1d(self, item) result(ierror) + class(list), intent(inout) :: self + character(kind=C_CHAR), dimension(:), intent(in) :: item + integer(kind=C_INT) :: ierror + + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + + if (ierror == 0_C_INT) then + ierror = PyList_Append(self%py_object, item_py) + call Py_DecRef(item_py) + endif +end function + +function list_append_chars(self, item) result(ierror) + class(list), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: item + integer(kind=C_INT) :: ierror + + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + + if (ierror == 0_C_INT) then + ierror = PyList_Append(self%py_object, item_py) + call Py_DecRef(item_py) + endif +end function + + +function list_copy(self, dest) result(ierror) + class(list), intent(in) :: self + type(list), intent(out) :: dest + integer(kind=C_INT) :: ierror + + ierror = list_create(dest, self) +end function + +function list_sort(self) result(ierror) + class(list), intent(inout) :: self + integer(kind=C_INT) :: ierror + + ierror = PyList_Sort(self%py_object) +end function + +function list_reverse(self) result(ierror) + class(list), intent(inout) :: self + integer(kind=C_INT) :: ierror + + ierror = PyList_Reverse(self%py_object) +end function + +!Creates new list by concatenating 'list_to_concatenate' +function list_add(self, result_list, list_to_concatenate) result(ierror) + class(list), intent(inout) :: self + type(list), intent(out) :: result_list + class(list), intent(in) :: list_to_concatenate + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + result_list%py_object = PySequence_Concat(self%py_object, list_to_concatenate%py_object) + if (.not. c_associated(result_list%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function list_insert_int32(self, ind, item) result(ierror) + class(list), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + class(object), intent(in) :: item + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_tmp + + ind_tmp = int(ind, PY_SSIZE_T_KIND) + ierror = PyList_Insert(self%py_object, ind_tmp, item%py_object) +end function + +function list_delitem_int32(self, ind) result(ierror) + class(list), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_tmp + + ind_tmp = int(ind, PY_SSIZE_T_KIND) + ierror = PySequence_DelItem(self%py_object, ind_tmp) +end function + +function list_insert_int64(self, ind, item) result(ierror) + class(list), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + class(object), intent(in) :: item + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_tmp + + ind_tmp = int(ind, PY_SSIZE_T_KIND) + ierror = PyList_Insert(self%py_object, ind_tmp, item%py_object) +end function + +function list_delitem_int64(self, ind) result(ierror) + class(list), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_tmp + + ind_tmp = int(ind, PY_SSIZE_T_KIND) + ierror = PySequence_DelItem(self%py_object, ind_tmp) +end function + + +function sequence_getitem_int32_object(self, item, ind) result(ierror) + class(Sequence), intent(inout) :: self + type(object), intent(out) :: item + integer(kind=int32), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item%py_object = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function sequence_getitem_int32_int32(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + integer(kind=int32), intent(out) :: item + integer(kind=int32), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int32_int64(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + integer(kind=int64), intent(out) :: item + integer(kind=int32), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int32_real32(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + real(kind=real32), intent(out) :: item + integer(kind=int32), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int32_real64(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + real(kind=real64), intent(out) :: item + integer(kind=int32), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int32_complex_real32(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + complex(kind=real32), intent(out) :: item + integer(kind=int32), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int32_complex_real64(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + complex(kind=real64), intent(out) :: item + integer(kind=int32), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int32_logical(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + logical, intent(out) :: item + integer(kind=int32), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int32_char_1d(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + character(kind=C_CHAR), dimension(:), pointer, intent(out) :: item + integer(kind=int32), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int32_chars(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + character(kind=C_CHAR, len=:), allocatable, intent(out) :: item + integer(kind=int32), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int64_object(self, item, ind) result(ierror) + class(Sequence), intent(inout) :: self + type(object), intent(out) :: item + integer(kind=int64), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item%py_object = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function sequence_getitem_int64_int32(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + integer(kind=int32), intent(out) :: item + integer(kind=int64), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int64_int64(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + integer(kind=int64), intent(out) :: item + integer(kind=int64), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int64_real32(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + real(kind=real32), intent(out) :: item + integer(kind=int64), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int64_real64(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + real(kind=real64), intent(out) :: item + integer(kind=int64), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int64_complex_real32(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + complex(kind=real32), intent(out) :: item + integer(kind=int64), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int64_complex_real64(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + complex(kind=real64), intent(out) :: item + integer(kind=int64), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int64_logical(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + logical, intent(out) :: item + integer(kind=int64), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int64_char_1d(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + character(kind=C_CHAR), dimension(:), pointer, intent(out) :: item + integer(kind=int64), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + +function sequence_getitem_int64_chars(self, item, ind) result(ierror) + class(Sequence), intent(in) :: self + character(kind=C_CHAR, len=:), allocatable, intent(out) :: item + integer(kind=int64), intent(in) :: ind + + integer(kind=C_INT) :: ierror + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + type(c_ptr) :: item_py + + ierror = 0_C_INT + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + item_py = PySequence_GetItem(self%py_object, ind_py_ssize_t) + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif +end function + + +function Sequence_len_int32(self, length) result(ierror) + class(Sequence), intent(in) :: self + integer(kind=int32), intent(out) :: length + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: length_tmp + + ierror = 0_C_INT + length_tmp = PyObject_Length(self%py_object) + length = int(length_tmp, int32) + + ! TODO: overflow check + if (length_tmp == -1_PY_SSIZE_T_KIND) then + ierror = EXCEPTION_ERROR + endif + +end function + +function Sequence_len_int64(self, length) result(ierror) + class(Sequence), intent(in) :: self + integer(kind=int64), intent(out) :: length + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: length_tmp + + ierror = 0_C_INT + length_tmp = PyObject_Length(self%py_object) + length = int(length_tmp, int64) + + ! TODO: overflow check + if (length_tmp == -1_PY_SSIZE_T_KIND) then + ierror = EXCEPTION_ERROR + endif + +end function + +function Mapping_len_int32(self, length) result(ierror) + class(Mapping), intent(in) :: self + integer(kind=int32), intent(out) :: length + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: length_tmp + + ierror = 0_C_INT + length_tmp = PyObject_Length(self%py_object) + length = int(length_tmp, int32) + + ! TODO: overflow check + if (length_tmp == -1_PY_SSIZE_T_KIND) then + ierror = EXCEPTION_ERROR + endif + +end function + +function Mapping_len_int64(self, length) result(ierror) + class(Mapping), intent(in) :: self + integer(kind=int64), intent(out) :: length + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: length_tmp + + ierror = 0_C_INT + length_tmp = PyObject_Length(self%py_object) + length = int(length_tmp, int64) + + ! TODO: overflow check + if (length_tmp == -1_PY_SSIZE_T_KIND) then + ierror = EXCEPTION_ERROR + endif + +end function + + +function sequence_index_int32(self, ind, item) result(ierror) + class(Sequence), intent(in) :: self + integer(kind=int32), intent(out) :: ind + class(object), intent(in) :: item + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_tmp + + ierror = 0_C_INT + ind_tmp = PySequence_Index(self%py_object, item%py_object) + ind = int(ind_tmp, int32) + + ! TODO: overflow check + if (ind_tmp == -1_PY_SSIZE_T_KIND) then + ierror = EXCEPTION_ERROR + endif + +end function + +function sequence_count_int32(self, the_count, item) result(ierror) + class(Sequence), intent(in) :: self + integer(kind=int32), intent(out) :: the_count + class(object), intent(in) :: item + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: the_count_tmp + + ierror = 0_C_INT + the_count_tmp = PySequence_Count(self%py_object, item%py_object) + the_count = int(the_count_tmp, int32) + + ! TODO: overflow check + if (the_count_tmp == -1_PY_SSIZE_T_KIND) then + ierror = EXCEPTION_ERROR + endif + +end function + +function sequence_index_int64(self, ind, item) result(ierror) + class(Sequence), intent(in) :: self + integer(kind=int64), intent(out) :: ind + class(object), intent(in) :: item + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_tmp + + ierror = 0_C_INT + ind_tmp = PySequence_Index(self%py_object, item%py_object) + ind = int(ind_tmp, int64) + + ! TODO: overflow check + if (ind_tmp == -1_PY_SSIZE_T_KIND) then + ierror = EXCEPTION_ERROR + endif + +end function + +function sequence_count_int64(self, the_count, item) result(ierror) + class(Sequence), intent(in) :: self + integer(kind=int64), intent(out) :: the_count + class(object), intent(in) :: item + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: the_count_tmp + + ierror = 0_C_INT + the_count_tmp = PySequence_Count(self%py_object, item%py_object) + the_count = int(the_count_tmp, int64) + + ! TODO: overflow check + if (the_count_tmp == -1_PY_SSIZE_T_KIND) then + ierror = EXCEPTION_ERROR + endif + +end function + + +function sequence_contains(self, contain_flag, item) result(ierror) + class(sequence), intent(in) :: self + logical, intent(out) :: contain_flag + class(object), intent(in) :: item + integer(kind=C_INT) :: ierror + + ! returns -1 on error, 0 if item not contained, 1 if contained + ierror = PySequence_Contains(self%py_object, item%py_object) + contain_flag = (ierror == 1_C_INT) + + if (contain_flag) then + ierror = 0_C_INT + endif + +end function + +function mutablesequence_setitem_int32_object(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + class(object), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item%py_object) + +end function + +function mutablesequence_setitem_int32_int32(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + integer(kind=int32), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int32_int64(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + integer(kind=int64), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int32_real32(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + real(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int32_real64(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + real(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int32_complex_real32(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + complex(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int32_complex_real64(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + complex(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int32_logical(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + logical, intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int32_char_1d(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + character(kind=C_CHAR), dimension(:), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int32_chars(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + character(kind=C_CHAR, len=*), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int64_object(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + class(object), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item%py_object) + +end function + +function mutablesequence_setitem_int64_int32(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + integer(kind=int32), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int64_int64(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + integer(kind=int64), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int64_real32(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + real(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int64_real64(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + real(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int64_complex_real32(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + complex(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int64_complex_real64(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + complex(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int64_logical(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + logical, intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int64_char_1d(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + character(kind=C_CHAR), dimension(:), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + +function mutablesequence_setitem_int64_chars(self, ind, item) result(ierror) + class(MutableSequence), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + character(kind=C_CHAR, len=*), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + type(c_ptr) :: item_py + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + if (ierror == 0) then + ierror = PySequence_SetItem(self%py_object, ind_py_ssize_t, item_py) + call Py_DecRef(item_py) + endif +end function + + + +! See also: http://stackoverflow.com/questions/6111843/limitations-of-pytuple-setitem +! Tuple ref-count must be 1 - otherwise cannot set items +function tuple_setitem_int32_int32(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + integer(kind=int32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int32_int64(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + integer(kind=int64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int32_real32(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + real(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int32_real64(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + real(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int32_complex_real32(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + complex(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int32_complex_real64(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + complex(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int32_logical(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + logical, intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int32_char_1d(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + character(kind=C_CHAR), dimension(:), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int32_chars(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + character(kind=C_CHAR, len=*), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int64_int32(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + integer(kind=int32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int64_int64(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + integer(kind=int64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int64_real32(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + real(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int64_real64(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + real(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int64_complex_real32(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + complex(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int64_complex_real64(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + complex(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int64_logical(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + logical, intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int64_char_1d(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + character(kind=C_CHAR), dimension(:), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + +function tuple_setitem_int64_chars(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + character(kind=C_CHAR, len=*), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ierror = box_value(item_py, item) + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + if (ierror == 0) then + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item_py) + ! note: no need for Py_DecRef since reference is stolen + endif +end function + + +function tuple_setitem_int32_object(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int32), intent(in) :: ind + class(object), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + ! therefore must increase ref-count of item + + call Py_IncRef(item%py_object) + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item%py_object) + +end function + +function tuple_setitem_int64_object(self, ind, item) result(ierror) + class(tuple), intent(inout) :: self + integer(kind=int64), intent(in) :: ind + class(object), intent(in) :: item + integer(kind=C_INT):: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ind_py_ssize_t + + ind_py_ssize_t = int(ind, PY_SSIZE_T_KIND) + + !tuple: must use PyTuple_SetItem + !PyTuple_SetItem steals a reference - in contrast to PyObject_SetItem + ! therefore must increase ref-count of item + + call Py_IncRef(item%py_object) + ierror = PyTuple_SetItem(self%py_object, ind_py_ssize_t, item%py_object) + +end function + + +function tuple_add(self, result_tuple, tuple_to_concatenate) result(ierror) + class(tuple), intent(inout) :: self + type(tuple), intent(out) :: result_tuple + class(tuple), intent(inout) :: tuple_to_concatenate + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + result_tuple%py_object = PySequence_Concat(self%py_object, tuple_to_concatenate%py_object) + if (.not. c_associated(result_tuple%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function object_getattribute(self, attr, attr_name) result(ierror) + class(object), intent(in) :: self + type(object), intent(out) :: attr + character(kind=C_CHAR, len=*), intent(in) :: attr_name + integer(kind=C_INT) :: ierror + + type(c_ptr) :: attr_name_str + + ierror = box_value(attr_name_str, attr_name) + + if (ierror == 0_C_INT) then + attr%py_object = PyObject_GetAttr(self%py_object, attr_name_str) + else + return + endif + + call Py_Decref(attr_name_str) + + if (.not. c_associated(attr%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function object_setattr(self, attr_name, attr_value) result(ierror) + class(object), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: attr_name + class(object), intent(in) :: attr_value + integer(kind=C_INT) :: ierror + + type(c_ptr) :: attr_name_str + + ierror = box_value(attr_name_str, attr_name) + + if (ierror == 0_C_INT) then + ierror = PyObject_SetAttr(self%py_object, attr_name_str, attr_value%py_object) + call Py_Decref(attr_name_str) + endif +end function + +function object_delattr(self, attr_name) result(ierror) + class(object), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: attr_name + integer(kind=C_INT) :: ierror + + type(c_ptr) :: attr_name_str + ierror = box_value(attr_name_str, attr_name) + + if (ierror == 0_C_INT) then + ierror = PyObject_SetAttr(self%py_object, attr_name_str, C_NULL_PTR) + call Py_Decref(attr_name_str) + endif +end function + +!> Get C pointer to an object, needed for developing Python extensions. +function object_get_c_ptr(self) result(r) + class(object), intent(in) :: self + type(c_ptr) :: r + r = self%py_object +end function + +subroutine object_destroy(self) + class(object), intent(inout) :: self + call Py_DecRef(self%py_object) +end subroutine + +function mapping_getitem_object_object(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + type(object), intent(out) :: item + class(object), intent(in) :: key + + integer(kind=C_INT) :: ierror + + item%py_object = PyObject_GetItem(self%py_object, key%py_object) + + if (.not. c_associated(item%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function mapping_getitem_int32_object(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + type(object), intent(out) :: item + integer(kind=int32), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item%py_object = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function mapping_getitem_int32_int32(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(out) :: item + integer(kind=int32), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int32_int64(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(out) :: item + integer(kind=int32), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int32_real32(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + real(kind=real32), intent(out) :: item + integer(kind=int32), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int32_real64(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + real(kind=real64), intent(out) :: item + integer(kind=int32), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int32_complex_real32(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + complex(kind=real32), intent(out) :: item + integer(kind=int32), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int32_complex_real64(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + complex(kind=real64), intent(out) :: item + integer(kind=int32), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int32_logical(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + logical, intent(out) :: item + integer(kind=int32), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int32_char_1d(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR), dimension(:), pointer, intent(out) :: item + integer(kind=int32), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int32_chars(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=:), allocatable, intent(out) :: item + integer(kind=int32), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int64_object(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + type(object), intent(out) :: item + integer(kind=int64), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item%py_object = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function mapping_getitem_int64_int32(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(out) :: item + integer(kind=int64), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int64_int64(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(out) :: item + integer(kind=int64), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int64_real32(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + real(kind=real32), intent(out) :: item + integer(kind=int64), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int64_real64(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + real(kind=real64), intent(out) :: item + integer(kind=int64), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int64_complex_real32(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + complex(kind=real32), intent(out) :: item + integer(kind=int64), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int64_complex_real64(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + complex(kind=real64), intent(out) :: item + integer(kind=int64), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int64_logical(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + logical, intent(out) :: item + integer(kind=int64), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int64_char_1d(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR), dimension(:), pointer, intent(out) :: item + integer(kind=int64), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_int64_chars(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=:), allocatable, intent(out) :: item + integer(kind=int64), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_chars_object(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + type(object), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item%py_object = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +function mapping_getitem_chars_int32(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_chars_int64(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_chars_real32(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + real(kind=real32), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_chars_real64(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + real(kind=real64), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_chars_complex_real32(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + complex(kind=real32), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_chars_complex_real64(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + complex(kind=real64), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_chars_logical(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + logical, intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_chars_char_1d(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR), dimension(:), pointer, intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + +function mapping_getitem_chars_chars(self, item, key) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=:), allocatable, intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + item_py = PyObject_GetItem(self%py_object, ind_py) + call Py_DecRef(ind_py) !don't need index anymore + + if (.not. c_associated(item_py)) then + ierror = EXCEPTION_ERROR + else + ierror = unbox_value(item, item_py) + call Py_DecRef(item_py) + endif + +end function + + +function mapping_setitem_object_object(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + class(object), intent(in) :: key + class(object), intent(in) :: item + integer(kind=C_INT):: ierror + + ierror = PyObject_SetItem(self%py_object, key%py_object, item%py_object) + +end function + +function mapping_delitem_object(self, key) result(ierror) + class(Mapping), intent(inout) :: self + class(object), intent(in) :: key + integer(kind=C_INT):: ierror + + ierror = PyObject_DelItem(self%py_object, key%py_object) + +end function + +function mapping_setitem_int32_object(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(in) :: key + class(object), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + ierror = PyObject_SetItem(self%py_object, ind_py, item%py_object) + call Py_DecRef(ind_py) + +end function + +function mapping_delitem_int32(self, key) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(in) :: key + integer(kind=C_INT):: ierror + + type(c_ptr) :: ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0_C_INT) then + return + endif + + ierror = PyObject_DelItem(self%py_object, ind_py) + call Py_DecRef(ind_py) + +end function + +function mapping_setitem_int32_int32(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(in) :: key + integer(kind=int32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int32_int64(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(in) :: key + integer(kind=int64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int32_real32(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(in) :: key + real(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int32_real64(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(in) :: key + real(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int32_complex_real32(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(in) :: key + complex(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int32_complex_real64(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(in) :: key + complex(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int32_logical(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(in) :: key + logical, intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int32_char_1d(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(in) :: key + character(kind=C_CHAR), dimension(:), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int32_chars(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int32), intent(in) :: key + character(kind=C_CHAR, len=*), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int64_object(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(in) :: key + class(object), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + ierror = PyObject_SetItem(self%py_object, ind_py, item%py_object) + call Py_DecRef(ind_py) + +end function + +function mapping_delitem_int64(self, key) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(in) :: key + integer(kind=C_INT):: ierror + + type(c_ptr) :: ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0_C_INT) then + return + endif + + ierror = PyObject_DelItem(self%py_object, ind_py) + call Py_DecRef(ind_py) + +end function + +function mapping_setitem_int64_int32(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(in) :: key + integer(kind=int32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int64_int64(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(in) :: key + integer(kind=int64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int64_real32(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(in) :: key + real(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int64_real64(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(in) :: key + real(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int64_complex_real32(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(in) :: key + complex(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int64_complex_real64(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(in) :: key + complex(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int64_logical(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(in) :: key + logical, intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int64_char_1d(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(in) :: key + character(kind=C_CHAR), dimension(:), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_int64_chars(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + integer(kind=int64), intent(in) :: key + character(kind=C_CHAR, len=*), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_chars_object(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: key + class(object), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0) then + return + endif + + ierror = PyObject_SetItem(self%py_object, ind_py, item%py_object) + call Py_DecRef(ind_py) + +end function + +function mapping_delitem_chars(self, key) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: key + integer(kind=C_INT):: ierror + + type(c_ptr) :: ind_py + + ierror = box_value(ind_py, key) + + if (ierror /= 0_C_INT) then + return + endif + + ierror = PyObject_DelItem(self%py_object, ind_py) + call Py_DecRef(ind_py) + +end function + +function mapping_setitem_chars_int32(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: key + integer(kind=int32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_chars_int64(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: key + integer(kind=int64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_chars_real32(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: key + real(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_chars_real64(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: key + real(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_chars_complex_real32(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: key + complex(kind=real32), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_chars_complex_real64(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: key + complex(kind=real64), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_chars_logical(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: key + logical, intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_chars_char_1d(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: key + character(kind=C_CHAR), dimension(:), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + +function mapping_setitem_chars_chars(self, key, item) result(ierror) + class(Mapping), intent(inout) :: self + character(kind=C_CHAR, len=*), intent(in) :: key + character(kind=C_CHAR, len=*), intent(in) :: item + integer(kind=C_INT):: ierror + + type(c_ptr) :: item_py, ind_py + + ierror = box_value(ind_py, key) + + if (ierror == 0_C_INT) then + ierror = box_value(item_py, item) + + if (ierror /= 0) then + call Py_DecRef(ind_py) + return + endif + endif + + if (ierror == 0_C_INT) then + ierror = PyObject_SetItem(self%py_object, ind_py, item_py) + call Py_DecRef(item_py) + call Py_DecRef(ind_py) + endif + +end function + + +function mapping_contains(self, contain_flag, item) result(ierror) + class(Mapping), intent(in) :: self + logical, intent(out) :: contain_flag + class(object), intent(in) :: item + integer(kind=C_INT) :: ierror + + integer(kind=C_INT) :: cont + ierror = 0_C_INT + ! returns 0 if item not contained, 1 if contained + ! in contrast to PySequence_Contains this never fails + ! we want to have the same call signature as with sequence objects + ! therefore we have ierror=0 as return value + cont = PyMapping_HasKey(self%py_object, item%py_object) + contain_flag = (cont == 1_C_INT) + +end function + +function dict_get_object_object(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + type(object), intent(out) :: item + class(object), intent(in) :: key + class(object), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + + ierror = dict_get_helper(self, item%py_object, key%py_object, default_value%py_object, .false.) + +end function + +function dict_get_int32_object(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + type(object), intent(out) :: item + integer(kind=int32), intent(in) :: key + class(object), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: key_ptr + + ierror = box_value(key_ptr, key) + if (ierror == 0_C_INT) then + ierror = dict_get_helper(self, item%py_object, key_ptr, default_value%py_object, .false.) + call Py_Decref(key_ptr) + endif +end function + +function dict_get_int32_int32(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + integer(kind=int32), intent(out) :: item + integer(kind=int32), intent(in) :: key + integer(kind=int32), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int32_int64(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + integer(kind=int64), intent(out) :: item + integer(kind=int32), intent(in) :: key + integer(kind=int64), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int32_real32(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + real(kind=real32), intent(out) :: item + integer(kind=int32), intent(in) :: key + real(kind=real32), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int32_real64(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + real(kind=real64), intent(out) :: item + integer(kind=int32), intent(in) :: key + real(kind=real64), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int32_complex_real32(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + complex(kind=real32), intent(out) :: item + integer(kind=int32), intent(in) :: key + complex(kind=real32), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int32_complex_real64(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + complex(kind=real64), intent(out) :: item + integer(kind=int32), intent(in) :: key + complex(kind=real64), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int32_logical(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + logical, intent(out) :: item + integer(kind=int32), intent(in) :: key + logical, intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int32_char_1d(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + character(kind=C_CHAR), dimension(:), pointer, intent(out) :: item + integer(kind=int32), intent(in) :: key + character(kind=C_CHAR), dimension(:), pointer, intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int32_chars(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + character(kind=C_CHAR, len=:), allocatable, intent(out) :: item + integer(kind=int32), intent(in) :: key + character(kind=C_CHAR, len=:), allocatable, intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int64_object(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + type(object), intent(out) :: item + integer(kind=int64), intent(in) :: key + class(object), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: key_ptr + + ierror = box_value(key_ptr, key) + if (ierror == 0_C_INT) then + ierror = dict_get_helper(self, item%py_object, key_ptr, default_value%py_object, .false.) + call Py_Decref(key_ptr) + endif +end function + +function dict_get_int64_int32(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + integer(kind=int32), intent(out) :: item + integer(kind=int64), intent(in) :: key + integer(kind=int32), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int64_int64(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + integer(kind=int64), intent(out) :: item + integer(kind=int64), intent(in) :: key + integer(kind=int64), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int64_real32(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + real(kind=real32), intent(out) :: item + integer(kind=int64), intent(in) :: key + real(kind=real32), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int64_real64(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + real(kind=real64), intent(out) :: item + integer(kind=int64), intent(in) :: key + real(kind=real64), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int64_complex_real32(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + complex(kind=real32), intent(out) :: item + integer(kind=int64), intent(in) :: key + complex(kind=real32), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int64_complex_real64(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + complex(kind=real64), intent(out) :: item + integer(kind=int64), intent(in) :: key + complex(kind=real64), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int64_logical(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + logical, intent(out) :: item + integer(kind=int64), intent(in) :: key + logical, intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int64_char_1d(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + character(kind=C_CHAR), dimension(:), pointer, intent(out) :: item + integer(kind=int64), intent(in) :: key + character(kind=C_CHAR), dimension(:), pointer, intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_int64_chars(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + character(kind=C_CHAR, len=:), allocatable, intent(out) :: item + integer(kind=int64), intent(in) :: key + character(kind=C_CHAR, len=:), allocatable, intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_chars_object(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + type(object), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + class(object), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: key_ptr + + ierror = box_value(key_ptr, key) + if (ierror == 0_C_INT) then + ierror = dict_get_helper(self, item%py_object, key_ptr, default_value%py_object, .false.) + call Py_Decref(key_ptr) + endif +end function + +function dict_get_chars_int32(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + integer(kind=int32), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + integer(kind=int32), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_chars_int64(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + integer(kind=int64), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + integer(kind=int64), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_chars_real32(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + real(kind=real32), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + real(kind=real32), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_chars_real64(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + real(kind=real64), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + real(kind=real64), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_chars_complex_real32(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + complex(kind=real32), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + complex(kind=real32), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_chars_complex_real64(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + complex(kind=real64), intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + complex(kind=real64), intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_chars_logical(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + logical, intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + logical, intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_chars_char_1d(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + character(kind=C_CHAR), dimension(:), pointer, intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + character(kind=C_CHAR), dimension(:), pointer, intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + +function dict_get_chars_chars(self, item, key, default_value) result(ierror) + class(dict), intent(inout) :: self + character(kind=C_CHAR, len=:), allocatable, intent(out) :: item + character(kind=C_CHAR, len=*), intent(in) :: key + character(kind=C_CHAR, len=:), allocatable, intent(in) :: default_value + + integer(kind=C_INT) :: ierror + type(c_ptr) :: item_ptr, key_ptr + + ierror = box_value(key_ptr, key) + if (ierror /= 0_C_INT) then + return + endif + + ierror = dict_get_helper2(self, item_ptr, key_ptr) + + if (c_associated(item_ptr) .and. ierror == 0_C_INT) then + ierror = unbox_value(item, item_ptr) + call Py_Decref(item_ptr) + else + item = default_value + endif + + call Py_Decref(key_ptr) + +end function + + +function dict_setdefault_object_object(self, the_value, key, default_value) result(ierror) + class(dict), intent(inout) :: self + !> The value retrieved from the dict. + type(object), intent(out) :: the_value + !> Key to retrieve value from. + class(object), intent(in) :: key + !> Default value that is inserted into dict and returned., if key is not present. + class(object), intent(in) :: default_value + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + ierror = dict_get_helper(self, the_value%py_object, key%py_object, default_value%py_object, .true.) + +end function + +function dict_get_helper(self, item_ptr, key_ptr, default_value_ptr, setdefault) result(ierror) + class(dict), intent(inout) :: self + type(c_ptr), intent(out) :: item_ptr + type(c_ptr), intent(in) :: key_ptr + type(c_ptr), intent(in) :: default_value_ptr + logical, intent(in) :: setdefault + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + item_ptr = PyObject_GetItem(self%py_object, key_ptr) + + if (.not. c_associated(item_ptr)) then + !always return default value, when lookup fails + item_ptr = default_value_ptr + call Py_IncRef(default_value_ptr) + + if (exception_matches(KeyError)) then + call err_clear() + + if (setdefault) then + ierror = PyObject_SetItem(self%py_object, key_ptr, default_value_ptr) + endif + else + ierror = EXCEPTION_ERROR + return + endif + endif +end function + +function dict_get_helper2(self, item_ptr, key_ptr) result(ierror) + class(dict), intent(inout) :: self + type(c_ptr), intent(out) :: item_ptr + type(c_ptr), intent(in) :: key_ptr + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + item_ptr = PyObject_GetItem(self%py_object, key_ptr) + + if (.not. c_associated(item_ptr)) then + if (exception_matches(KeyError)) then + call err_clear() + else + ierror = EXCEPTION_ERROR + return + endif + endif +end function + +!----------------------------------------------------------------------------------------------------- +! bytes, str and unicode + +function bytes_create_chars(r, string) result(ierror) + type(bytes), intent(out) :: r + character(kind=C_CHAR, len=*), intent(in) :: string + integer(kind=C_INT) :: ierror + + ierror = box_value_chars_as_bytestr(r%py_object, string) +end function + +function bytes_create_char_1d(r, string) result(ierror) + type(bytes), intent(out) :: r + character(kind=C_CHAR), dimension(:), intent(in) :: string + integer(kind=C_INT) :: ierror + + ierror = box_value_char_1d_as_bytestr(r%py_object, string) +end function + +function unicode_create_chars(r, string) result(ierror) + type(unicode), intent(out) :: r + character(kind=C_CHAR, len=*), intent(in) :: string + integer(kind=C_INT) :: ierror + + ierror = box_value_chars_as_unicodestr(r%py_object, string) +end function + +function unicode_create_char_1d(r, string) result(ierror) + type(unicode), intent(out) :: r + character(kind=C_CHAR), dimension(:), intent(in) :: string + integer(kind=C_INT) :: ierror + + ierror = box_value_char_1d_as_unicodestr(r%py_object, string) +end function + +function str_create_chars(r, string) result(ierror) + type(str), intent(out) :: r + character(kind=C_CHAR, len=*), intent(in) :: string + integer(kind=C_INT) :: ierror + +#ifdef PYTHON2 + ierror = box_value_chars_as_bytestr(r%py_object, string) +#else + ierror = box_value_chars_as_unicodestr(r%py_object, string) +#endif +end function + +function str_create_char_1d(r, string) result(ierror) + type(str), intent(out) :: r + character(kind=C_CHAR), dimension(:), intent(in) :: string + integer(kind=C_INT) :: ierror + +#ifdef PYTHON2 + ierror = box_value_char_1d_as_bytestr(r%py_object, string) +#else + ierror = box_value_char_1d_as_unicodestr(r%py_object, string) +#endif +end function + +function str_create_object(r, obj) result(ierror) + type(str), intent(out) :: r + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + r%py_object = PyObject_Str(obj%py_object) + if (.not. c_associated(r%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +!----------------------------------------------------------------------------------------------------- +!> Import a Python module. +!> +!> Module must be in Python module search path. +!> The search path can be set via the environment variable PYTHONPATH or by +!> manipulating the list of paths retrieved by using [[get_sys_path]]. +function import_py(mod_py, mod_name) result(ierror) + !> The imported module + type(module_py), intent(out) :: mod_py + !> Name of the module to import. Name can include dots "." + character(kind=C_CHAR, len=*), intent(in) :: mod_name + !> Error code, 0 on success. + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + mod_py%py_object = PyImport_ImportModule(trim(mod_name) // C_NULL_CHAR) + + if (.not. c_associated(mod_py%py_object)) then + ierror = EXCEPTION_ERROR + endif +end function + +!----------------------------------------------------------------------------------------------------- +!> Calling an object (method, function...) that is a member of another Python object (module,...). +!> +!> Python equivalent: return_value = obj.attr_name(*args, **kwargs) +function call_py_attribute(return_value, obj, attr_name, args, kwargs) result(ierror) + type(object), intent(out) :: return_value + class(object), intent(in) :: obj + character(kind=C_CHAR, len=*), intent(in) :: attr_name + class(tuple), intent(in), optional :: args + class(dict), intent(in), optional :: kwargs + + integer(kind=C_INT) :: ierror + + type(object) :: obj_to_call + ierror = obj%getattribute(obj_to_call, attr_name) + + if (ierror == 0) then + + if (present(kwargs) .and. present(args)) then + ierror = call_py_object(return_value, obj_to_call, args, kwargs) + elseif (present(args)) then + ierror = call_py_object_nokwargs(return_value, obj_to_call, args) + elseif (present(kwargs)) then + ierror = call_py_object_only_kwargs(return_value, obj_to_call, kwargs) + else + ierror = call_py_object_noargs(return_value, obj_to_call) + endif + + call obj_to_call%destroy() + endif +end function + +!> Calling a Python object (method, function...). +!> +!> Python equivalent: return_value = obj_to_call(*args, **kwargs) +function call_py_object(return_value, obj_to_call, args, kwargs) result(ierror) + type(object), intent(out) :: return_value + class(object), intent(in) :: obj_to_call + class(tuple), intent(in):: args + class(dict), intent(in) :: kwargs + + integer(kind=C_INT) :: ierror + + type(c_ptr) :: kw, args_ptr + + ierror = 0_C_INT + + kw = kwargs%py_object + args_ptr = args%py_object + + return_value%py_object = PyObject_Call(obj_to_call%py_object, args_ptr, kw) + + if (.not. c_associated(return_value%py_object)) then + ierror = EXCEPTION_ERROR + endif + +end function + +!> Python equivalent: return_value = obj_to_call(*args) +function call_py_object_nokwargs(return_value, obj_to_call, args) result(ierror) + type(object), intent(out) :: return_value + class(object), intent(in) :: obj_to_call + class(tuple), intent(in):: args + + integer(kind=C_INT) :: ierror + type(dict) :: kwargs + + ierror = dict_create(kwargs) + if (ierror == 0) then + ierror = call_py_object(return_value, obj_to_call, args, kwargs) + call kwargs%destroy + endif +end function + +!> Python equivalent: return_value = obj_to_call() +function call_py_object_noargs(return_value, obj_to_call) result(ierror) + type(object), intent(out) :: return_value + class(object), intent(in) :: obj_to_call + + integer(kind=C_INT) :: ierror + type(tuple) :: args + + ierror = tuple_create(args, 0) + if (ierror == 0) then + ierror = call_py_object_nokwargs(return_value, obj_to_call, args) + call args%destroy + endif +end function + +!> Python equivalent: return_value = obj_to_call(**kwargs) +function call_py_object_only_kwargs(return_value, obj_to_call, kwargs) result(ierror) + type(object), intent(out) :: return_value + class(object), intent(in) :: obj_to_call + class(dict), intent(in) :: kwargs + + integer(kind=C_INT) :: ierror + type(tuple) :: args + + ierror = tuple_create(args, 0) + if (ierror == 0) then + ierror = call_py_object(return_value, obj_to_call, args, kwargs) + call args%destroy + endif +end function + +!> Python equivalent: obj.attr_name(*args, **kwargs) +function call_py_noret_attribute(obj, attr_name, args, kwargs) result(ierror) + class(object), intent(in) :: obj + character(kind=C_CHAR, len=*), intent(in) :: attr_name + class(tuple), intent(in), optional :: args + class(dict), intent(in), optional :: kwargs + + integer(kind=C_INT) :: ierror + type(object) :: return_value + + if (present(kwargs) .and. present(args)) then + ierror = call_py(return_value, obj, attr_name, args, kwargs) + elseif (present(args)) then + ierror = call_py(return_value, obj, attr_name, args) + elseif (present(kwargs)) then + ierror = call_py(return_value, obj, attr_name, kwargs=kwargs) + else + ierror = call_py(return_value, obj, attr_name) + endif + + call return_value%destroy + +end function + +!> Python equivalent: obj.attr_name(*args, **kwargs) +function call_py_noret_object(obj_to_call, args, kwargs) result(ierror) + class(object), intent(in) :: obj_to_call + class(tuple), intent(in), optional :: args + class(dict), intent(in), optional :: kwargs + + integer(kind=C_INT) :: ierror + type(object) :: return_value + + if (present(kwargs) .and. present(args)) then + ierror = call_py(return_value, obj_to_call, args, kwargs) + elseif (present(args)) then + ierror = call_py(return_value, obj_to_call, args) + elseif (present(kwargs)) then + ierror = call_py(return_value, obj_to_call, kwargs=kwargs) + else + ierror = call_py(return_value, obj_to_call) + endif + + call return_value%destroy +end function + +!----------------------------------------------------------------------------------------------------- +! Numpy ndarray support + +function ndarray_create_nocopy_int32_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + integer(kind=int32), dimension(:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 4_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "i" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "int32") +#endif + +end function + +function ndarray_create_int32_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + integer(kind=int32), dimension(:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int32), dimension(:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "int32") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_int32_1d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + integer(kind=int32), dimension(:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "i" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_int64_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + integer(kind=int64), dimension(:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "l" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "int64") +#endif + +end function + +function ndarray_create_int64_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + integer(kind=int64), dimension(:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int64), dimension(:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "int64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_int64_1d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + integer(kind=int64), dimension(:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "l" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_real32_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + real(kind=real32), dimension(:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 4_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "f" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "float32") +#endif + +end function + +function ndarray_create_real32_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + real(kind=real32), dimension(:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + real(kind=real32), dimension(:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "float32") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_real32_1d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + real(kind=real32), dimension(:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "f" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_real64_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + real(kind=real64), dimension(:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "d" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "float64") +#endif + +end function + +function ndarray_create_real64_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + real(kind=real64), dimension(:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + real(kind=real64), dimension(:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "float64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_real64_1d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + real(kind=real64), dimension(:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "d" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_complex_real32_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + complex(kind=real32), dimension(:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "Zf" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "complex64") +#endif + +end function + +function ndarray_create_complex_real32_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + complex(kind=real32), dimension(:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + complex(kind=real32), dimension(:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "complex64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_complex_real32_1d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + complex(kind=real32), dimension(:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "Zf" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_complex_real64_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + complex(kind=real64), dimension(:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 16_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "Zd" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "complex128") +#endif + +end function + +function ndarray_create_complex_real64_1d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + complex(kind=real64), dimension(:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + complex(kind=real64), dimension(:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "complex128") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_complex_real64_1d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + complex(kind=real64), dimension(:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 1 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "Zd" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_int32_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + integer(kind=int32), dimension(:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 4_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "i" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "int32") +#endif + +end function + +function ndarray_create_int32_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + integer(kind=int32), dimension(:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int32), dimension(:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "int32") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_int32_2d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + integer(kind=int32), dimension(:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "i" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_int64_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + integer(kind=int64), dimension(:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "l" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "int64") +#endif + +end function + +function ndarray_create_int64_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + integer(kind=int64), dimension(:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int64), dimension(:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "int64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_int64_2d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + integer(kind=int64), dimension(:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "l" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_real32_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + real(kind=real32), dimension(:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 4_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "f" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "float32") +#endif + +end function + +function ndarray_create_real32_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + real(kind=real32), dimension(:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + real(kind=real32), dimension(:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "float32") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_real32_2d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + real(kind=real32), dimension(:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "f" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_real64_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + real(kind=real64), dimension(:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "d" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "float64") +#endif + +end function + +function ndarray_create_real64_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + real(kind=real64), dimension(:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + real(kind=real64), dimension(:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "float64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_real64_2d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + real(kind=real64), dimension(:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "d" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_complex_real32_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + complex(kind=real32), dimension(:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "Zf" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "complex64") +#endif + +end function + +function ndarray_create_complex_real32_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + complex(kind=real32), dimension(:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + complex(kind=real32), dimension(:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "complex64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_complex_real32_2d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + complex(kind=real32), dimension(:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "Zf" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_complex_real64_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + complex(kind=real64), dimension(:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 16_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "Zd" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "complex128") +#endif + +end function + +function ndarray_create_complex_real64_2d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + complex(kind=real64), dimension(:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + complex(kind=real64), dimension(:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "complex128") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_complex_real64_2d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + complex(kind=real64), dimension(:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 2 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "Zd" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_int32_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + integer(kind=int32), dimension(:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 4_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "i" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "int32") +#endif + +end function + +function ndarray_create_int32_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + integer(kind=int32), dimension(:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int32), dimension(:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "int32") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_int32_3d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + integer(kind=int32), dimension(:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "i" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_int64_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + integer(kind=int64), dimension(:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "l" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "int64") +#endif + +end function + +function ndarray_create_int64_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + integer(kind=int64), dimension(:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int64), dimension(:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "int64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_int64_3d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + integer(kind=int64), dimension(:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "l" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_real32_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + real(kind=real32), dimension(:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 4_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "f" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "float32") +#endif + +end function + +function ndarray_create_real32_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + real(kind=real32), dimension(:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + real(kind=real32), dimension(:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "float32") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_real32_3d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + real(kind=real32), dimension(:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "f" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_real64_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + real(kind=real64), dimension(:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "d" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "float64") +#endif + +end function + +function ndarray_create_real64_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + real(kind=real64), dimension(:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + real(kind=real64), dimension(:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "float64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_real64_3d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + real(kind=real64), dimension(:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "d" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_complex_real32_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + complex(kind=real32), dimension(:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "Zf" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "complex64") +#endif + +end function + +function ndarray_create_complex_real32_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + complex(kind=real32), dimension(:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + complex(kind=real32), dimension(:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "complex64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_complex_real32_3d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + complex(kind=real32), dimension(:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "Zf" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_complex_real64_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + complex(kind=real64), dimension(:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 16_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "Zd" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "complex128") +#endif + +end function + +function ndarray_create_complex_real64_3d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + complex(kind=real64), dimension(:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + complex(kind=real64), dimension(:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "complex128") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_complex_real64_3d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + complex(kind=real64), dimension(:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 3 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "Zd" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_int32_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + integer(kind=int32), dimension(:,:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 4_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "i" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "int32") +#endif + +end function + +function ndarray_create_int32_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + integer(kind=int32), dimension(:,:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int32), dimension(:,:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "int32") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_int32_4d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + integer(kind=int32), dimension(:,:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "i" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_int64_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + integer(kind=int64), dimension(:,:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "l" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "int64") +#endif + +end function + +function ndarray_create_int64_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + integer(kind=int64), dimension(:,:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int64), dimension(:,:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "int64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_int64_4d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + integer(kind=int64), dimension(:,:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "l" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_real32_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + real(kind=real32), dimension(:,:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 4_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "f" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "float32") +#endif + +end function + +function ndarray_create_real32_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + real(kind=real32), dimension(:,:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + real(kind=real32), dimension(:,:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "float32") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_real32_4d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + real(kind=real32), dimension(:,:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "f" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_real64_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + real(kind=real64), dimension(:,:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "d" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "float64") +#endif + +end function + +function ndarray_create_real64_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + real(kind=real64), dimension(:,:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + real(kind=real64), dimension(:,:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "float64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_real64_4d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + real(kind=real64), dimension(:,:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "d" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_complex_real32_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + complex(kind=real32), dimension(:,:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 8_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "Zf" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "complex64") +#endif + +end function + +function ndarray_create_complex_real32_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + complex(kind=real32), dimension(:,:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + complex(kind=real32), dimension(:,:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "complex64") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_complex_real32_4d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + complex(kind=real32), dimension(:,:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "Zf" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + +function ndarray_create_nocopy_complex_real64_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> The Fortran array to wrap as ndarray. NO copy is made. Changes to the ndarray affect the Fortran array and + !> vice versa. MUST be a contiguous array (this is not checked). + ! Note: can not use the F2008 CONTIGUOUS attribute here, because a + ! temporary copy of array could be created with limited lifetime. + complex(kind=real64), dimension(:,:,:,:), target, intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), parameter :: ITEMSIZE = 16_PY_SSIZE_T_KIND + +#ifndef PYTHON2 + ierror = ndarray_create_nocopy_helper(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "Zd" // C_NULL_CHAR) +#else + ierror = ndarray_create_nocopy_helper_py2(res, c_loc(array), shape(array, kind=PY_SSIZE_T_KIND), NDIM, ITEMSIZE, "complex128") +#endif + +end function + +function ndarray_create_complex_real64_4d(res, array) result(ierror) + !> The resulting ndarray (in Fortran storage order). + type(ndarray), intent(out) :: res + !> Create a new ndarray with a copy of the data given in 'array' + complex(kind=real64), dimension(:,:,:,:), intent(in) :: array + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + complex(kind=real64), dimension(:,:,:,:), pointer :: ptr + + ierror = ndarray_create_empty(res, shape(array, kind=PY_SSIZE_T_KIND), "complex128") + if (ierror /= 0_C_INT) return + ierror = res%get_data(ptr) + if (ierror /= 0_C_INT) then + call res%destroy + res%py_object = C_NULL_PTR + return + endif + ptr = array +end function + +!> Get pointer to data of numpy array +!> +!> Raises BufferError, if array is not contiguous (does not have the required Fortran or C storage order) +!> Raises TypeError, if Fortran pointer datatype is not compatible with numpy datatype. +function get_data_complex_real64_4d(self, ptr, order) result(ierror) + class(ndarray), intent(in) :: self + !> Pointer to the numerical data of the Fortran array. + complex(kind=real64), dimension(:,:,:,:), pointer, intent(out) :: ptr + !> Only retrieve data, when ndarray has certain order. + !> + !> If 'F' (default), only retrieve the data when the ndarray has Fortran storage order. + !> If 'C', only retrieve the data when the ndarray has C storage order. + !> ATTENTION: The data, the pointer points to, then will be the transpose of the array. + !> If 'A' accept Fortran or C order. If C, the data will be transposed. + character(kind=C_CHAR), optional, intent(in) :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(c_ptr) :: raw_ptr + integer, parameter :: NDIM = 4 + integer(kind=PY_SSIZE_T_KIND), dimension(NDIM) :: shape_info + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + nullify(ptr) + ierror = get_data_helper(self, raw_ptr, shape_info, NDIM, "Zd" // C_NULL_CHAR, the_order) + + if (ierror == 0_C_INT) then + call c_f_pointer(raw_ptr, ptr, shape=shape_info) + if (.not. associated(ptr)) then + ierror = EXCEPTION_ERROR + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + endif + endif +end function + + +#ifndef PYTHON2 +function ndarray_create_nocopy_helper(res, array_c_loc, array_shape, ndim, itemsize, format_c_string) result(ierror) + type(ndarray), intent(inout) :: res + type(c_ptr), intent(in) :: array_c_loc + integer, intent(in) :: ndim + integer(kind=PY_SSIZE_T_KIND), target, dimension(ndim), intent(in) :: array_shape + integer(kind=PY_SSIZE_T_KIND) :: itemsize + character(kind=C_CHAR, len=*), target, intent(in) :: format_c_string + integer(kind=C_INT) :: ierror + + type(Py_buffer) :: buffer + integer(kind=PY_SSIZE_T_KIND), target, dimension(ndim) :: strides + integer(kind=PY_SSIZE_T_KIND) :: length + type(c_ptr) :: mem_view + type(c_ptr) :: args + integer :: ii + + !TODO: check if numpy was successfully imported + + ierror = 0_C_INT + res%py_object = C_NULL_PTR + + length = 1 + do ii = 1, ndim + length = length * array_shape(ii) + enddo + + ! calculate the strides assuming Fortran-order + call PyBuffer_FillContiguousStrides(int(ndim, kind=C_INT), c_loc(array_shape), c_loc(strides), itemsize, 'F') + + buffer%buf = array_c_loc + buffer%obj = C_NULL_PTR + buffer%len = length * ITEMSIZE + buffer%itemsize = itemsize + buffer%readonly = 0_C_INT + buffer%ndim = int(ndim, C_INT) + buffer%format = c_loc(format_c_string) + buffer%shape = c_loc(array_shape) + buffer%strides = c_loc(strides) + buffer%suboffsets = C_NULL_PTR +#ifdef PYTHON2 + buffer%smalltable = 0_PY_SSIZE_T_KIND +#endif + buffer%internal = C_NULL_PTR + + mem_view = PyMemoryView_FromBuffer(buffer) + if (.not. c_associated(mem_view)) then + ierror = -1_C_INT + return + endif + + args = PyTuple_New(1_PY_SSIZE_T_KIND) + if (c_associated(args)) then + ierror = PyTuple_SetItem(args, 0_PY_SSIZE_T_KIND, mem_view) ! steals reference to mem_view even if it fails + + if (ierror /= 0_C_INT) then + call Py_Decref(args) + return + endif + + res%py_object = PyObject_Call(global_numpy_asarray_method, args, C_NULL_PTR) + call Py_Decref(args) + + if (.not. c_associated(res%py_object)) then + ierror = -1_C_INT + endif + + else ! .not. c_associated(args) + call Py_Decref(mem_view) + ierror = -1_C_INT + endif + +end function +#endif + +#ifdef PYTHON2 +! Python 2 array wrapper creation using old-style, py2-only buffer object + np.frombuffer. +! In principle with Py 2.7 it would be possible to use the same code as +! in the Py 3 case, but the memoryview + np.asarray +! approach is somewhat buggy in Py 2 and one reference is lost +function ndarray_create_nocopy_helper_py2(res, array_c_loc, array_shape, ndim, itemsize, dtype) result(ierror) + type(ndarray), intent(inout) :: res + type(c_ptr), intent(in) :: array_c_loc + integer, intent(in) :: ndim + integer(kind=PY_SSIZE_T_KIND), target, dimension(ndim), intent(in) :: array_shape + integer(kind=PY_SSIZE_T_KIND) :: itemsize + character(kind=C_CHAR, len=*), target, intent(in) :: dtype + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: length + type(c_ptr) :: buffer_obj + type(module_py) :: numpy + type(tuple) :: args + type(object) :: retval + type(object) :: buffer + type(ndarray) :: reshaped_array + integer :: ii + + ierror = -1_C_INT + res%py_object = C_NULL_PTR + + length = 1 + do ii = 1, ndim + length = length * array_shape(ii) + enddo + + buffer_obj = PyBuffer_FromReadWriteMemory(array_c_loc, length*itemsize) + if (.not. c_associated(buffer_obj)) then + return + endif + + buffer%py_object = buffer_obj + + ierror = tuple_create(args, 2_PY_SSIZE_T_KIND) + if (ierror /= 0_C_INT) then + call buffer%destroy + return + endif + + ierror = args%setitem(0_PY_SSIZE_T_KIND, buffer) + if (ierror /= 0_C_INT) then + call args%destroy + call buffer%destroy + return + endif + + ierror = args%setitem(1_PY_SSIZE_T_KIND, dtype) + if (ierror /= 0_C_INT) then + call args%destroy + call buffer%destroy + return + endif + + numpy%py_object = global_numpy_mod + ierror = call_py(retval, numpy, "frombuffer", args) + call args%destroy + call buffer%destroy + + if (ierror == 0_C_INT) then + res%py_object = retval%py_object + else + call retval%destroy + return + endif + + if (ndim > 1) then + ierror = ndarray_reshape_helper(reshaped_array, res, array_shape, 'F') + call res%destroy + + if (ierror == 0_C_INT) then + res%py_object = reshaped_array%py_object + else + res%py_object = C_NULL_PTR + endif + endif +end function + +function ndarray_reshape_helper(reshaped_array, array, new_shape, order) result(ierror) + type(ndarray), intent(out) :: reshaped_array + class(ndarray), intent(in) :: array + integer(kind=PY_SSIZE_T_KIND), dimension(:), intent(in) :: new_shape + character(kind=C_CHAR), intent(in) :: order + integer(kind=C_INT) :: ierror + + type(tuple) :: args + type(dict) :: kwargs + type(tuple) :: new_shape_tuple + type(object) :: retval + + reshaped_array%py_object = C_NULL_PTR + + ierror = tuple_from_array(new_shape_tuple, new_shape) + if (ierror /= 0_C_INT) then + return + endif + + ierror = tuple_create(args, 1_PY_SSIZE_T_KIND) + if (ierror /= 0_C_INT) then + call new_shape_tuple%destroy + return + endif + + ierror = args%setitem(0_PY_SSIZE_T_KIND, new_shape_tuple) + if (ierror /= 0_C_INT) then + call args%destroy + call new_shape_tuple%destroy + return + endif + + ierror = dict_create(kwargs) + if (ierror /= 0_C_INT) then + call args%destroy + call new_shape_tuple%destroy + return + endif + + ierror = kwargs%setitem("order", order) + if (ierror /= 0_C_INT) then + call kwargs%destroy + call args%destroy + call new_shape_tuple%destroy + return + endif + + ierror = call_py(retval, array, "reshape", args, kwargs) + if (ierror == 0_C_INT) then + ierror = cast(reshaped_array, retval) + call retval%destroy + endif + + call kwargs%destroy + call args%destroy + call new_shape_tuple%destroy +end function +#endif + +!> Get pointer to data of numpy array +function get_data_helper(self, raw_ptr, shape_info, ndim, format_c_string, order) result(ierror) + class(ndarray), intent(in) :: self + type(c_ptr), intent(out) :: raw_ptr + integer, intent(in) :: ndim + integer(kind=PY_SSIZE_T_KIND), dimension(ndim), intent(out) :: shape_info + character(kind=C_CHAR, len=*), target, intent(in) :: format_c_string + character(kind=C_CHAR), intent(in) :: order + + integer(kind=C_INT) :: ierror, flag + type(Py_buffer) :: buffer + integer(kind=PY_SSIZE_T_KIND), dimension(:), pointer :: shape_ptr + integer :: shape_info_shape(1) + character(kind=C_CHAR) :: detected_order + character(kind=C_CHAR,len=60) :: error_message + + ! order can have values 'C', 'F' or 'A' + if (index('CFA', order) == 0) then + ierror = EXCEPTION_ERROR + call raise_exception(ValueError, "ndarray%get_data: order parameter must be 'F', 'C' or 'A'") + return + endif + + shape_info_shape(1) = ndim + + ! raises BufferError exception if array is not contiguous, Python 2: ValueError + ierror = PyObject_GetBuffer(self%py_object, buffer, 156_C_INT) !flags (PyBUF_FORMAT | PyBUF_ANY_CONTIGUOUS) - we need the format info and PyBUF_FORMAT alone gives error + + if (ierror /= 0) then + if (exception_matches(BufferError) .or. exception_matches(ValueError)) then ! make error message more informative + call err_clear + call raise_exception(BufferError, "forpy: ndarray with non-contiguous data. Fortran or C-order needed: try to copy array") + endif + return + endif + + detected_order = 'N' + flag = PyBuffer_IsContiguous(buffer, 'F') + if (flag == 1_C_INT) then + detected_order = 'F' + else + flag = PyBuffer_IsContiguous(buffer, 'C') + if (flag == 1_C_INT) then + detected_order = 'C' + endif + endif + + if ((detected_order == 'N') .or. (ndim > 1 .and. order /= 'A' .and. order /= detected_order)) then + ierror = EXCEPTION_ERROR + if (order=='F') then + error_message = "forpy: expected Fortran-ordered array" + elseif (order=='C') then + error_message = "forpy: expected C-ordered array" + else + error_message = "forpy: expected contiguous array" + endif + call PyBuffer_Release(buffer) + call raise_exception(BufferError, error_message) + return + endif + + if (buffer%ndim /= ndim) then + ierror = EXCEPTION_ERROR + write(error_message,fmt="('forpy: expected array of rank ',I1,', got array of rank ',I1)") ndim, buffer%ndim + call PyBuffer_Release(buffer) + call raise_exception(TypeError, error_message) + return + endif + + !get shape info + call c_f_pointer(buffer%shape, shape_ptr, shape=SHAPE_INFO_SHAPE) + + !check if correct format + if (associated(shape_ptr)) then + if (get_data_helper_check_dtype(buffer%format, format_c_string) /= 0) then + ierror = EXCEPTION_ERROR + call PyBuffer_Release(buffer) + call raise_exception(TypeError, "forpy: ndarray%get_data - datatype of data pointer is incompatible with ndarray") + return + endif + else + ierror = EXCEPTION_ERROR + call PyBuffer_Release(buffer) + call raise_exception(RuntimeError, "forpy: Could not determine shape of ndarray") + return + endif + + raw_ptr = buffer%buf + + call get_shape_info_helper(shape_info, shape_ptr, detected_order) + call PyBuffer_Release(buffer) + +end function + +! returns 0 if dtype matches fortran type, non-zero if not +function get_data_helper_check_dtype(buffer_format, format_c_string) result(flag) + type(c_ptr), intent(in) :: buffer_format + character(kind=C_CHAR, len=*), target, intent(in) :: format_c_string + + character(kind=C_CHAR, len=2), target :: format_code + integer(kind=C_INT) :: flag + + flag = 1_C_INT + + ! the Python buffer format codes corresponding to int32 and int64 are systems dependent... + + if (format_c_string == "i" // C_NULL_CHAR) then ! buffer type compatible with int32 requested + if (int32 == C_INT) then + format_code = "i" // C_NULL_CHAR + flag = strcmp(buffer_format, c_loc(format_code)) + endif + if (flag /= 0) then + if (int32 == C_LONG) then + format_code = "l" // C_NULL_CHAR + flag = strcmp(buffer_format, c_loc(format_code)) + endif + endif + return + endif + + if (format_c_string == "l" // C_NULL_CHAR) then ! buffer type compatible with int64 requested + if (int64 == C_LONG) then + format_code = "l" // C_NULL_CHAR + flag = strcmp(buffer_format, c_loc(format_code)) + endif + if (flag /= 0) then + if (int64 == C_LONG_LONG) then + format_code = "q" // C_NULL_CHAR + flag = strcmp(buffer_format, c_loc(format_code)) + endif + endif + if (flag /= 0) then + if (int64 == C_INT) then + format_code = "i" // C_NULL_CHAR + flag = strcmp(buffer_format, c_loc(format_code)) + endif + endif + return + endif + + ! this handles all the non-integer cases + flag = strcmp(buffer_format, c_loc(format_c_string)) +end function + +subroutine get_shape_info_helper(shape_info, shape_ptr, order) + integer(kind=PY_SSIZE_T_KIND), dimension(:), intent(out) :: shape_info + integer(kind=PY_SSIZE_T_KIND), dimension(:), intent(in) :: shape_ptr + character(kind=C_CHAR), intent(in) :: order + + integer ii, length + + if (order == 'F') then + shape_info = shape_ptr + elseif (order == 'C') then ! C-order: reverse shape information ("transpose") + length = size(shape_info) + do ii = 1, length + shape_info(ii) = shape_ptr(length-ii+1) + enddo + endif +end subroutine + +!> Return transpose of a ndarray. +function ndarray_transpose(self, transposed_array) result(ierror) + class(ndarray), intent(in) :: self + type(ndarray), intent(out) :: transposed_array + integer(kind=C_INT) :: ierror + + type(object) :: retval + + ierror = call_py(retval, self, "transpose") + if (ierror == 0_C_INT) then + ierror = cast(transposed_array, retval) + call retval%destroy + endif +end function + +!> Returns copy of a ndarray +!> +!> order (optional) can be 'F', 'C', 'A' or 'K' +!> (default is 'F' - in numpy it is 'C') +function ndarray_copy(self, array_copy, order) result(ierror) + class(ndarray), intent(in) :: self + type(ndarray), intent(out) :: array_copy + character(kind=C_CHAR), intent(in), optional :: order + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR) :: the_order + type(object) :: retval + type(tuple) :: args + + if (.not. present(order)) then + the_order = 'F' + else + the_order = order + endif + + ierror = tuple_create(args, 1_PY_SSIZE_T_KIND) + if (ierror /= 0_C_INT) then + return + endif + + ierror = args%setitem(0_PY_SSIZE_T_KIND, the_order) + if (ierror == 0_C_INT) then + ierror = call_py(retval, self, "copy", args) + endif + + call args%destroy + + if (ierror == 0_C_INT) then + ierror = cast(array_copy, retval) + call retval%destroy + endif +end function + +!> Checks if data of ndarray has a specific storage-order. +!> +!> order can be 'F' (Fortran-order), 'C' (C-order), 'A' (Fortran- or C-order) +function ndarray_is_ordered(self, order) result(is_ordered) + class(ndarray), intent(in) :: self + character(kind=C_CHAR), intent(in) :: order + logical :: is_ordered + + type(object) :: retval, flags + integer(kind=C_INT) :: ierror + logical :: c_ordered, fortran_ordered, check_c, check_f + + is_ordered = .false. + c_ordered = .false. + fortran_ordered = .false. + + if (have_exception()) return + + ierror = self%getattribute(flags, "flags") + if (ierror /= 0_C_INT) then + call err_clear + return + endif + + check_f = (order == 'F') .or. (order == 'A') + + if (check_f) then + ierror = flags%getattribute(retval, "f_contiguous") + if (ierror /= 0_C_INT) then + call flags%destroy + call err_clear + return + endif + ierror = cast(fortran_ordered, retval) + call retval%destroy + if (ierror /= 0_C_INT) then + call flags%destroy + call err_clear + return + endif + endif + + check_c = (order == 'C') .or. (order == 'A' .and. .not. fortran_ordered) + + if (check_c) then + ierror = flags%getattribute(retval, "c_contiguous") + if (ierror /= 0_C_INT) then + call flags%destroy + call err_clear + return + endif + ierror = cast(c_ordered, retval) + call retval%destroy + if (ierror /= 0_C_INT) then + call flags%destroy + call err_clear + return + endif + endif + + call flags%destroy + is_ordered = fortran_ordered .or. c_ordered + +end function + +!> Returns type string of ndarray. +!> +!> corresponds to Python's ndarray.dtype.name property +function ndarray_get_dtype_name(self, dtype_name) result(ierror) + class(ndarray), intent(in) :: self + character(kind=C_CHAR, len=:), allocatable, intent(out) :: dtype_name + integer(kind=C_INT) :: ierror + + type(object) :: dtype, dname + + ierror = self%getattribute(dtype, "dtype") + if (ierror /= 0_C_INT) then + return + endif + + ierror = dtype%getattribute(dname, "name") + if (ierror /= 0_C_INT) then + call dtype%destroy + return + endif + + ierror = cast(dtype_name, dname) + call dtype%destroy + call dname%destroy +end function + +!> Returns dimensionality of ndarray (ndarray.ndim) +function ndarray_ndim_int32(self, ndim) result(ierror) + class(ndarray), intent(in) :: self + !> Output: dimensionality of array. + integer(kind=int32), intent(out) :: ndim + integer(kind=C_INT) :: ierror + + type(object) :: ndim_obj + + ierror = self%getattribute(ndim_obj, "ndim") + if (ierror /= 0_C_INT) then + return + endif + + ierror = cast(ndim, ndim_obj) + call ndim_obj%destroy +end function + +!> Returns dimensionality of ndarray (ndarray.ndim) +function ndarray_ndim_int64(self, ndim) result(ierror) + class(ndarray), intent(in) :: self + !> Output: dimensionality of array. + integer(kind=int64), intent(out) :: ndim + integer(kind=C_INT) :: ierror + + type(object) :: ndim_obj + + ierror = self%getattribute(ndim_obj, "ndim") + if (ierror /= 0_C_INT) then + return + endif + + ierror = cast(ndim, ndim_obj) + call ndim_obj%destroy +end function + + +!---Routines for creating ndarrays with Python managed storage --------- +! numpy.empty, numpy.ones, numpy.zeros + +function ndarray_create_empty_aint32(array, a_shape, dtype, order) result(ierror) + !> The resulting ndarray. + type(ndarray), intent(out) :: array + !> Shape of ndarray to create. + integer(kind=int32), dimension(:), intent(in) :: a_shape + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F') + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "empty", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int32(array, "empty", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "empty", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int32(array, "empty", a_shape, "", "F") + endif + endif +end function + +function ndarray_create_empty_aint64(array, a_shape, dtype, order) result(ierror) + !> The resulting ndarray. + type(ndarray), intent(out) :: array + !> Shape of ndarray to create. + integer(kind=int64), dimension(:), intent(in) :: a_shape + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F') + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "empty", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int64(array, "empty", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "empty", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int64(array, "empty", a_shape, "", "F") + endif + endif +end function + + +function ndarray_create_empty_int32(array, length, dtype, order) result(ierror) + !> The resulting one dimensional ndarray. + type(ndarray), intent(out) :: array + !> Number of elements in ndarray + integer(kind=int32), intent(in) :: length + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F'). In case of 1D array not relevant. + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int32) :: a_shape(1) + a_shape(1) = length + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "empty", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int32(array, "empty", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "empty", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int32(array, "empty", a_shape, "", "F") + endif + endif +end function + +function ndarray_create_empty_int64(array, length, dtype, order) result(ierror) + !> The resulting one dimensional ndarray. + type(ndarray), intent(out) :: array + !> Number of elements in ndarray + integer(kind=int64), intent(in) :: length + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F'). In case of 1D array not relevant. + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int64) :: a_shape(1) + a_shape(1) = length + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "empty", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int64(array, "empty", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "empty", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int64(array, "empty", a_shape, "", "F") + endif + endif +end function + +function ndarray_create_zeros_aint32(array, a_shape, dtype, order) result(ierror) + !> The resulting ndarray. + type(ndarray), intent(out) :: array + !> Shape of ndarray to create. + integer(kind=int32), dimension(:), intent(in) :: a_shape + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F') + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "zeros", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int32(array, "zeros", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "zeros", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int32(array, "zeros", a_shape, "", "F") + endif + endif +end function + +function ndarray_create_zeros_aint64(array, a_shape, dtype, order) result(ierror) + !> The resulting ndarray. + type(ndarray), intent(out) :: array + !> Shape of ndarray to create. + integer(kind=int64), dimension(:), intent(in) :: a_shape + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F') + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "zeros", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int64(array, "zeros", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "zeros", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int64(array, "zeros", a_shape, "", "F") + endif + endif +end function + + +function ndarray_create_zeros_int32(array, length, dtype, order) result(ierror) + !> The resulting one dimensional ndarray. + type(ndarray), intent(out) :: array + !> Number of elements in ndarray + integer(kind=int32), intent(in) :: length + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F'). In case of 1D array not relevant. + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int32) :: a_shape(1) + a_shape(1) = length + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "zeros", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int32(array, "zeros", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "zeros", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int32(array, "zeros", a_shape, "", "F") + endif + endif +end function + +function ndarray_create_zeros_int64(array, length, dtype, order) result(ierror) + !> The resulting one dimensional ndarray. + type(ndarray), intent(out) :: array + !> Number of elements in ndarray + integer(kind=int64), intent(in) :: length + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F'). In case of 1D array not relevant. + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int64) :: a_shape(1) + a_shape(1) = length + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "zeros", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int64(array, "zeros", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "zeros", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int64(array, "zeros", a_shape, "", "F") + endif + endif +end function + +function ndarray_create_ones_aint32(array, a_shape, dtype, order) result(ierror) + !> The resulting ndarray. + type(ndarray), intent(out) :: array + !> Shape of ndarray to create. + integer(kind=int32), dimension(:), intent(in) :: a_shape + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F') + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "ones", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int32(array, "ones", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "ones", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int32(array, "ones", a_shape, "", "F") + endif + endif +end function + +function ndarray_create_ones_aint64(array, a_shape, dtype, order) result(ierror) + !> The resulting ndarray. + type(ndarray), intent(out) :: array + !> Shape of ndarray to create. + integer(kind=int64), dimension(:), intent(in) :: a_shape + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F') + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "ones", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int64(array, "ones", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "ones", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int64(array, "ones", a_shape, "", "F") + endif + endif +end function + + +function ndarray_create_ones_int32(array, length, dtype, order) result(ierror) + !> The resulting one dimensional ndarray. + type(ndarray), intent(out) :: array + !> Number of elements in ndarray + integer(kind=int32), intent(in) :: length + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F'). In case of 1D array not relevant. + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int32) :: a_shape(1) + a_shape(1) = length + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "ones", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int32(array, "ones", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int32(array, "ones", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int32(array, "ones", a_shape, "", "F") + endif + endif +end function + +function ndarray_create_ones_int64(array, length, dtype, order) result(ierror) + !> The resulting one dimensional ndarray. + type(ndarray), intent(out) :: array + !> Number of elements in ndarray + integer(kind=int64), intent(in) :: length + !> numpy.dtype of ndarray (default: 'float') + character(kind=C_CHAR, len=*), intent(in), optional :: dtype + !> Storage order: 'F' (Fortran) or 'C' (default: 'F'). In case of 1D array not relevant. + character(kind=C_CHAR), intent(in), optional :: order + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer(kind=int64) :: a_shape(1) + a_shape(1) = length + + if (present(dtype)) then + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "ones", a_shape, dtype, order) + else + ! Fortran order as default, in contrast to numpy + ierror = ndarray_create_special_impl_int64(array, "ones", a_shape, dtype, "F") + endif + else + if (present(order)) then + ierror = ndarray_create_special_impl_int64(array, "ones", a_shape, "", order) + else + ierror = ndarray_create_special_impl_int64(array, "ones", a_shape, "", "F") + endif + endif +end function + + +function ndarray_create_special_impl_int32(array, creator_function, a_shape, dtype, order) result(ierror) + type(ndarray), intent(out) :: array + character(kind=C_CHAR, len=*), intent(in) :: creator_function + integer(kind=int32), dimension(:), intent(in) :: a_shape + character(kind=C_CHAR, len=*), intent(in) :: dtype + character(kind=C_CHAR), intent(in) :: order + integer(kind=C_INT) :: ierror + + type(dict) :: kwargs + + ierror = dict_create(kwargs) + if (ierror /= 0_C_INT) return + + if (len(dtype) > 0) then + ierror = kwargs%setitem("dtype", dtype) + if (ierror /= 0_C_INT) then + call kwargs%destroy + return + endif + endif + + ierror = kwargs%setitem("order", order) + + if (ierror == 0_C_INT) then + ierror = ndarray_create_special_helper_int32(array, creator_function, a_shape, kwargs) + endif + + call kwargs%destroy +end function + +function ndarray_create_special_getargs_int32(args, a_shape) result(ierror) + type(tuple), intent(out) :: args + integer(kind=int32), dimension(:), intent(in) :: a_shape + integer(kind=C_INT) :: ierror + + type(tuple) :: shape_tuple + + ierror = tuple_from_array_int32(shape_tuple, a_shape) + if (ierror /= 0_C_INT) return + + ierror = tuple_create(args, 1_PY_SSIZE_T_KIND) + if (ierror /= 0_C_INT) then + call shape_tuple%destroy + return + endif + + ierror = args%setitem(0_PY_SSIZE_T_KIND, shape_tuple) + call shape_tuple%destroy +end function + +function ndarray_create_special_helper_int32(array, creator_function, a_shape, kwargs) result(ierror) + type(ndarray), intent(out) :: array + character(kind=C_CHAR, len=*), intent(in) :: creator_function + integer(kind=int32), dimension(:), intent(in) :: a_shape + type(dict), intent(in) :: kwargs + integer(kind=C_INT) :: ierror + + type(tuple) :: args + type(object) :: retval + type(module_py) :: numpy_mod + + ierror = ndarray_create_special_getargs_int32(args, a_shape) + if (ierror /= 0_C_INT) return + + numpy_mod%py_object = global_numpy_mod + ierror = call_py(retval, numpy_mod, creator_function, args, kwargs) + + if (ierror == 0_C_INT) then + ierror = cast(array, retval) + call retval%destroy + endif + + call args%destroy + +end function + +!> Helper function: create tuple from integer array +function tuple_from_array_int32(tu, arr) result(ierror) + type(tuple), intent(out) :: tu + integer(kind=int32), dimension(:), intent(in) :: arr + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ii, ndim + ndim = size(arr, kind=PY_SSIZE_T_KIND) + + ierror = tuple_create(tu, ndim) + if (ierror /= 0_C_INT) return + + do ii = 1, ndim + ierror = tu%setitem(ii-1, arr(ii)) + if (ierror /= 0_C_INT) then + call tu%destroy + return + endif + enddo +end function + +function ndarray_create_special_impl_int64(array, creator_function, a_shape, dtype, order) result(ierror) + type(ndarray), intent(out) :: array + character(kind=C_CHAR, len=*), intent(in) :: creator_function + integer(kind=int64), dimension(:), intent(in) :: a_shape + character(kind=C_CHAR, len=*), intent(in) :: dtype + character(kind=C_CHAR), intent(in) :: order + integer(kind=C_INT) :: ierror + + type(dict) :: kwargs + + ierror = dict_create(kwargs) + if (ierror /= 0_C_INT) return + + if (len(dtype) > 0) then + ierror = kwargs%setitem("dtype", dtype) + if (ierror /= 0_C_INT) then + call kwargs%destroy + return + endif + endif + + ierror = kwargs%setitem("order", order) + + if (ierror == 0_C_INT) then + ierror = ndarray_create_special_helper_int64(array, creator_function, a_shape, kwargs) + endif + + call kwargs%destroy +end function + +function ndarray_create_special_getargs_int64(args, a_shape) result(ierror) + type(tuple), intent(out) :: args + integer(kind=int64), dimension(:), intent(in) :: a_shape + integer(kind=C_INT) :: ierror + + type(tuple) :: shape_tuple + + ierror = tuple_from_array_int64(shape_tuple, a_shape) + if (ierror /= 0_C_INT) return + + ierror = tuple_create(args, 1_PY_SSIZE_T_KIND) + if (ierror /= 0_C_INT) then + call shape_tuple%destroy + return + endif + + ierror = args%setitem(0_PY_SSIZE_T_KIND, shape_tuple) + call shape_tuple%destroy +end function + +function ndarray_create_special_helper_int64(array, creator_function, a_shape, kwargs) result(ierror) + type(ndarray), intent(out) :: array + character(kind=C_CHAR, len=*), intent(in) :: creator_function + integer(kind=int64), dimension(:), intent(in) :: a_shape + type(dict), intent(in) :: kwargs + integer(kind=C_INT) :: ierror + + type(tuple) :: args + type(object) :: retval + type(module_py) :: numpy_mod + + ierror = ndarray_create_special_getargs_int64(args, a_shape) + if (ierror /= 0_C_INT) return + + numpy_mod%py_object = global_numpy_mod + ierror = call_py(retval, numpy_mod, creator_function, args, kwargs) + + if (ierror == 0_C_INT) then + ierror = cast(array, retval) + call retval%destroy + endif + + call args%destroy + +end function + +!> Helper function: create tuple from integer array +function tuple_from_array_int64(tu, arr) result(ierror) + type(tuple), intent(out) :: tu + integer(kind=int64), dimension(:), intent(in) :: arr + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: ii, ndim + ndim = size(arr, kind=PY_SSIZE_T_KIND) + + ierror = tuple_create(tu, ndim) + if (ierror /= 0_C_INT) return + + do ii = 1, ndim + ierror = tu%setitem(ii-1, arr(ii)) + if (ierror /= 0_C_INT) then + call tu%destroy + return + endif + enddo +end function + + +!------------------ Routines for wrapping values into Python objects ("boxing") ---------------------- +#ifndef PYTHON2 +function box_value_int32_as_long(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + integer(kind=int32), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + integer(kind=C_LONG_LONG) :: tmp + ierror = 0_C_INT + + tmp = int(the_value, C_LONG_LONG) + + obj = PyLong_FromLongLong(tmp) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function +#endif + +function box_value_int64_as_long(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + integer(kind=int64), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + integer(kind=C_LONG_LONG) :: tmp + ierror = 0_C_INT + + tmp = int(the_value, C_LONG_LONG) + + obj = PyLong_FromLongLong(tmp) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function + +#ifdef PYTHON2 +function box_value_int32(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + integer(kind=int32), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + integer(kind=C_LONG) :: tmp + ierror = 0_C_INT + + tmp = int(the_value, C_LONG) + + obj = PyInt_FromLong(tmp) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function + +function box_value_int64(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + integer(kind=int64), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + integer(kind=C_LONG) :: tmp + ierror = 0_C_INT + + ! this is the case for Windows and 32-bit Linux + if (huge(the_value) > huge(tmp)) then + if (the_value > huge(tmp) .or. the_value < -huge(tmp)) then + if (the_value /= (-huge(tmp) - 1)) then + !overflow: must use 'long'-type + ierror = box_value_int64_as_long(obj, the_value) + return + endif + endif + endif + + tmp = int(the_value, C_LONG) + + obj = PyInt_FromLong(tmp) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function +#endif + +function box_value_real32(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + real(kind=real32), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + real(kind=C_DOUBLE) :: tmp + + ierror = 0_C_INT + + tmp = real(the_value, C_DOUBLE) + + obj = PyFloat_FromDouble(tmp) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function + +function box_value_real64(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + real(kind=real64), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + real(kind=C_DOUBLE) :: tmp + + ierror = 0_C_INT + + tmp = real(the_value, C_DOUBLE) + + obj = PyFloat_FromDouble(tmp) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function + +function box_value_complex_real32(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + complex(kind=real32), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + + obj = PyComplex_FromDoubles(real(the_value, C_DOUBLE), real(aimag(the_value), C_DOUBLE)) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function +function box_value_complex_real64(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + complex(kind=real64), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + + obj = PyComplex_FromDoubles(real(the_value, C_DOUBLE), real(aimag(the_value), C_DOUBLE)) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function + +function box_value_chars(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + character(kind=C_CHAR, len=*), intent(in) :: the_value + integer(kind=C_INT) :: ierror + +#ifdef PYTHON2 + ierror = box_value_chars_as_bytestr(obj, the_value) +#else + ierror = box_value_chars_as_unicodestr(obj, the_value) +#endif + +end function + +function box_value_chars_as_bytestr(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + character(kind=C_CHAR, len=*), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: length + + ierror = 0_C_INT + + length = len(the_value) + + obj = PyBytes_FromStringAndSize(the_value, length) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function + +function box_value_chars_as_unicodestr(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + character(kind=C_CHAR, len=*), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: length + + ierror = 0_C_INT + + length = len(the_value) + + obj = PyUnicode_DecodeUTF8(the_value, length, "strict" // C_NULL_CHAR) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function + +function box_value_char_1d(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + character(kind=C_CHAR), dimension(:), intent(in) :: the_value + integer(kind=C_INT) :: ierror + +#ifdef PYTHON2 + ierror = box_value_char_1d_as_bytestr(obj, the_value) +#else + ierror = box_value_char_1d_as_unicodestr(obj, the_value) +#endif + +end function + +function box_value_char_1d_as_bytestr(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + character(kind=C_CHAR), dimension(:), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: length + + ierror = 0_C_INT + + length = size(the_value) + + obj = PyBytes_FromStringAndSize(the_value, length) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function + +function box_value_char_1d_as_unicodestr(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + character(kind=C_CHAR), dimension(:), intent(in) :: the_value + integer(kind=C_INT) :: ierror + + integer(kind=PY_SSIZE_T_KIND) :: length + + ierror = 0_C_INT + + length = size(the_value) + + obj = PyUnicode_DecodeUTF8(the_value, length, "strict" // C_NULL_CHAR) + + if (.not. c_associated(obj)) then + ierror = EXCEPTION_ERROR + endif + +end function + + +function box_value_logical(obj, the_value) result(ierror) + type(c_ptr), intent(out) :: obj + logical, intent(in) :: the_value + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + + if (the_value) then + obj = global_Py_TrueStruct_ptr + call Py_IncRef(obj) + else + obj = global_Py_FalseStruct_ptr + call Py_IncRef(obj) + endif + +end function + +!------------- Routines for unboxing ----------------------------------- +function unbox_value_int32(the_value, obj) result(ierror) + integer(kind=int32), intent(out) :: the_value + type(c_ptr), intent(in) :: obj + integer(kind=C_INT) :: ierror + + integer(kind=C_LONG_LONG) :: tmp + integer :: overflow + type(c_ptr) :: err_obj + + ierror = 0_C_INT + tmp = PyLong_AsLongLongAndOverflow(obj, overflow) + the_value = int(tmp, int32) + + if (tmp == -1_C_LONG_LONG) then + if (overflow == 0) then + err_obj = PyErr_Occurred() + if (c_associated(err_obj)) then + ierror = EXCEPTION_ERROR + return + endif + else + ierror = EXCEPTION_ERROR + call raise_exception(OverflowError, "int too big to convert") + return + endif + endif + + if (huge(the_value) < huge(tmp)) then + if (tmp > huge(the_value) .or. tmp < -huge(the_value)) then + if (tmp /= (-huge(the_value) - 1)) then + ierror = EXCEPTION_ERROR + call raise_exception(OverflowError, "int too large for Fortran integer(kind=int32)") + endif + endif + endif + +end function + +function unbox_value_int64(the_value, obj) result(ierror) + integer(kind=int64), intent(out) :: the_value + type(c_ptr), intent(in) :: obj + integer(kind=C_INT) :: ierror + + integer(kind=C_LONG_LONG) :: tmp + integer :: overflow + type(c_ptr) :: err_obj + + ierror = 0_C_INT + tmp = PyLong_AsLongLongAndOverflow(obj, overflow) + the_value = int(tmp, int64) + + if (tmp == -1_C_LONG_LONG) then + if (overflow == 0) then + err_obj = PyErr_Occurred() + if (c_associated(err_obj)) then + ierror = EXCEPTION_ERROR + return + endif + else + ierror = EXCEPTION_ERROR + call raise_exception(OverflowError, "int too big to convert") + return + endif + endif + + if (huge(the_value) < huge(tmp)) then + if (tmp > huge(the_value) .or. tmp < -huge(the_value)) then + if (tmp /= (-huge(the_value) - 1)) then + ierror = EXCEPTION_ERROR + call raise_exception(OverflowError, "int too large for Fortran integer(kind=int64)") + endif + endif + endif + +end function + + +function unbox_value_real32(the_value, obj) result(ierror) + real(kind=real32), intent(out) :: the_value + type(c_ptr), intent(in) :: obj + integer(kind=C_INT) :: ierror + + real(kind=C_DOUBLE) :: tmp + type(c_ptr) :: err_obj + + ierror = 0_C_INT + tmp = PyFloat_AsDouble(obj) + the_value = real(tmp, real32) + + if (tmp == -1.0_C_DOUBLE) then + err_obj = PyErr_Occurred() + if (c_associated(err_obj)) then + ierror = EXCEPTION_ERROR + return + endif + endif + +end function + +function unbox_value_real64(the_value, obj) result(ierror) + real(kind=real64), intent(out) :: the_value + type(c_ptr), intent(in) :: obj + integer(kind=C_INT) :: ierror + + real(kind=C_DOUBLE) :: tmp + type(c_ptr) :: err_obj + + ierror = 0_C_INT + tmp = PyFloat_AsDouble(obj) + the_value = real(tmp, real64) + + if (tmp == -1.0_C_DOUBLE) then + err_obj = PyErr_Occurred() + if (c_associated(err_obj)) then + ierror = EXCEPTION_ERROR + return + endif + endif + +end function + + +function unbox_value_complex_real32(the_value, obj) result(ierror) + complex(kind=real32), intent(out) :: the_value + type(c_ptr), intent(in) :: obj + integer(kind=C_INT) :: ierror + + type(Py_complex) :: tmp + type(c_ptr) :: err_obj + + ierror = 0_C_INT + tmp = PyComplex_AsCComplex(obj) !this handles objects with __complex__ method correctly + + the_value = cmplx(tmp%real_part, tmp%imag_part, kind=real32) + + if (tmp%real_part == -1.0_C_DOUBLE) then + err_obj = PyErr_Occurred() + if (c_associated(err_obj)) then + ierror = EXCEPTION_ERROR + return + endif + endif + +end function + +function unbox_value_complex_real64(the_value, obj) result(ierror) + complex(kind=real64), intent(out) :: the_value + type(c_ptr), intent(in) :: obj + integer(kind=C_INT) :: ierror + + type(Py_complex) :: tmp + type(c_ptr) :: err_obj + + ierror = 0_C_INT + tmp = PyComplex_AsCComplex(obj) !this handles objects with __complex__ method correctly + + the_value = cmplx(tmp%real_part, tmp%imag_part, kind=real64) + + if (tmp%real_part == -1.0_C_DOUBLE) then + err_obj = PyErr_Occurred() + if (c_associated(err_obj)) then + ierror = EXCEPTION_ERROR + return + endif + endif + +end function + + +function unbox_value_logical(the_value, obj) result(ierror) + logical, intent(out) :: the_value + type(c_ptr), intent(in) :: obj + integer(kind=C_INT) :: ierror + + the_value = .false. + ierror = PyObject_IsTrue(obj) + if (ierror /= -1_C_INT) then + the_value = (ierror == 1_C_INT) + ierror = 0_C_INT + endif +end function + +! unboxes WITHOUT making a copy - returns a pointer +! do not change string via pointer, since they are supposed to be +! immutable in Python +function unbox_value_char_1d(the_value, obj) result(ierror) + character(kind=C_CHAR), pointer, dimension(:), intent(out) :: the_value + type(c_ptr), intent(in) :: obj + integer(kind=C_INT) :: ierror + + type(c_ptr) :: char_ptr + integer(PY_SSIZE_T_KIND) :: length(1) + + logical :: obj_is_bytes + type(object) :: dummy_obj ! just to be able to use is_bytes and is_unicode + + ierror = 0_C_INT + dummy_obj%py_object = obj + + obj_is_bytes = is_bytes(dummy_obj) + + if (obj_is_bytes) then + char_ptr = PyBytes_AsString(obj) + elseif (is_unicode(dummy_obj)) then +#ifndef PYTHON2 + !C-API-function not available in PY2 + char_ptr = PyUnicode_AsUTF8AndSize(obj, length(1)) +#else + char_ptr = C_NULL_PTR + call raise_exception(TypeError, "forpy: cast of unicode object to character array not supported when using Python 2") +#endif + else + char_ptr = C_NULL_PTR + endif + + if (.not. c_associated(char_ptr)) then + ierror = EXCEPTION_ERROR + if (.not. have_exception()) then + call raise_exception(TypeError, "forpy: Cannot cast to character array") + endif + return + endif + + if (obj_is_bytes) then + length(1) = PyObject_Length(obj) + endif + + if (length(1) == -1_PY_SSIZE_T_KIND) then + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Cannot cast to character array") + return + endif + + ! length 0 strings also seem to work + + call c_f_pointer(char_ptr, the_value, length) + +end function + +! unboxes by making a copy +function unbox_value_chars(the_value, obj) result(ierror) + character(kind=C_CHAR, len=:), allocatable, intent(out) :: the_value + type(c_ptr), intent(in) :: obj + integer(kind=C_INT) :: ierror + + character(kind=C_CHAR), dimension(:), pointer :: char_ptr + + ierror = unbox_value_char_1d(char_ptr, obj) + + if (ierror == 0_C_INT) then + call char_1d_to_chars(char_ptr, the_value) + endif + +end function + +#ifdef PYTHON2 +function unbox_value_chars_py2(the_value, obj) result(ierror) + + character(kind=C_CHAR, len=:), allocatable, intent(out) :: the_value + type(c_ptr), intent(in) :: obj + integer(kind=C_INT) :: ierror + + type(c_ptr) :: bytes_obj + type(object) :: dummy_obj + + dummy_obj%py_object = obj + ierror = EXCEPTION_ERROR + + ! py2 unicode strategy: convert to Python str object first + if (is_unicode(dummy_obj)) then + bytes_obj = PyUnicode_AsUTF8String(obj) + if (c_associated(bytes_obj)) then + ierror = unbox_value_chars(the_value, bytes_obj) + call Py_Decref(bytes_obj) + endif + else + ierror = unbox_value_chars(the_value, obj) + endif +end function +#endif + +subroutine char_1d_to_chars(inp, outp) + character(kind=C_CHAR), dimension(:), intent(in) :: inp + character(kind=C_CHAR, len=:), allocatable, intent(inout) :: outp + + integer :: length, ii + + length = size(inp) + + if (allocated(outp)) then + deallocate(outp) + endif + + allocate(character(kind=C_CHAR, len=length) :: outp) + + do ii = 1, length + outp(ii:ii) = inp(ii) + enddo + +end subroutine + +!------------- Routines for (safely) casting types --------------------- +! Note: They do not transfer ownership to casted object - both input and +! output object have to be destroyed + +function cast_to_list(list_out, obj) result(ierror) + type(list), intent(out) :: list_out + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_list(obj)) then + ierror = 0_C_INT + list_out%py_object = obj%py_object + call Py_IncRef(obj%py_object) + else + list_out%py_object = C_NULL_PTR + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to list.") + endif +end function + +function cast_to_dict(dict_out, obj) result(ierror) + type(dict), intent(out) :: dict_out + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_dict(obj)) then + ierror = 0_C_INT + dict_out%py_object = obj%py_object + call Py_IncRef(obj%py_object) + else + dict_out%py_object = C_NULL_PTR + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to dict.") + endif +end function + +function cast_to_tuple(tuple_out, obj) result(ierror) + type(tuple), intent(out) :: tuple_out + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_tuple(obj)) then + ierror = 0_C_INT + tuple_out%py_object = obj%py_object + call Py_IncRef(obj%py_object) + else + tuple_out%py_object = C_NULL_PTR + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to tuple.") + endif +end function + +function cast_to_NoneType(NoneType_out, obj) result(ierror) + type(NoneType), intent(out) :: NoneType_out + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_none(obj)) then + ierror = 0_C_INT + NoneType_out%py_object = obj%py_object + call Py_IncRef(obj%py_object) + else + NoneType_out%py_object = C_NULL_PTR + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to NoneType.") + endif +end function + +function cast_to_ndarray(ndarray_out, obj) result(ierror) + type(ndarray), intent(out) :: ndarray_out + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_ndarray(obj)) then + ierror = 0_C_INT + ndarray_out%py_object = obj%py_object + call Py_IncRef(obj%py_object) + else + ndarray_out%py_object = C_NULL_PTR + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to ndarray.") + endif +end function + +function cast_to_str(str_out, obj) result(ierror) + type(str), intent(out) :: str_out + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_str(obj)) then + ierror = 0_C_INT + str_out%py_object = obj%py_object + call Py_IncRef(obj%py_object) + else + str_out%py_object = C_NULL_PTR + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to str.") + endif +end function + +function cast_to_bytes(bytes_out, obj) result(ierror) + type(bytes), intent(out) :: bytes_out + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_bytes(obj)) then + ierror = 0_C_INT + bytes_out%py_object = obj%py_object + call Py_IncRef(obj%py_object) + else + bytes_out%py_object = C_NULL_PTR + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to bytes.") + endif +end function + +function cast_to_unicode(unicode_out, obj) result(ierror) + type(unicode), intent(out) :: unicode_out + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_unicode(obj)) then + ierror = 0_C_INT + unicode_out%py_object = obj%py_object + call Py_IncRef(obj%py_object) + else + unicode_out%py_object = C_NULL_PTR + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to unicode.") + endif +end function + + +function cast_nonstrict_to_list(list_out, obj) result(ierror) + type(list), intent(out) :: list_out + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_list(obj)) then + ierror = 0_C_INT + list_out%py_object = obj%py_object + call Py_IncRef(obj%py_object) + else + ierror = list_create(list_out, obj) + endif +end function + +function cast_nonstrict_to_tuple(tuple_out, obj) result(ierror) + type(tuple), intent(out) :: tuple_out + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_tuple(obj)) then + ierror = 0_C_INT + tuple_out%py_object = obj%py_object + call Py_IncRef(obj%py_object) + else + ierror = tuple_create(tuple_out, obj) + endif +end function + +function cast_nonstrict_to_str(str_out, obj) result(ierror) + type(str), intent(out) :: str_out + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_str(obj)) then + ierror = 0_C_INT + str_out%py_object = obj%py_object + call Py_IncRef(obj%py_object) + else + ierror = str_create(str_out, obj) + endif +end function + + +function cast_to_object(plain_obj, obj) result(ierror) + type(object), intent(out) :: plain_obj + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + ierror = 0_C_INT + plain_obj%py_object = obj%py_object + call Py_IncRef(obj%py_object) +end function + +! casts to scalar fortran types + +function cast_to_int32(out_value, obj) result(ierror) + integer(kind=int32), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_int(obj)) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to integer(kind=int32).") + endif +end function + +function cast_to_int32_flex(out_value, obj, strict) result(ierror) + integer(kind=int32), intent(out) :: out_value + class(object), intent(in) :: obj + logical, intent(in) :: strict + integer(kind=C_INT) :: ierror + + if (.not. strict) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = cast_to_int32(out_value, obj) + endif +end function + +function cast_nonstrict_to_int32(out_value, obj) result(ierror) + integer(kind=int32), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + ierror = cast(out_value, obj, .false.) +end function + +function cast_to_int64(out_value, obj) result(ierror) + integer(kind=int64), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_int(obj)) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to integer(kind=int64).") + endif +end function + +function cast_to_int64_flex(out_value, obj, strict) result(ierror) + integer(kind=int64), intent(out) :: out_value + class(object), intent(in) :: obj + logical, intent(in) :: strict + integer(kind=C_INT) :: ierror + + if (.not. strict) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = cast_to_int64(out_value, obj) + endif +end function + +function cast_nonstrict_to_int64(out_value, obj) result(ierror) + integer(kind=int64), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + ierror = cast(out_value, obj, .false.) +end function + +function cast_to_real32(out_value, obj) result(ierror) + real(kind=real32), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_float(obj)) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to real(kind=real32).") + endif +end function + +function cast_to_real32_flex(out_value, obj, strict) result(ierror) + real(kind=real32), intent(out) :: out_value + class(object), intent(in) :: obj + logical, intent(in) :: strict + integer(kind=C_INT) :: ierror + + if (.not. strict) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = cast_to_real32(out_value, obj) + endif +end function + +function cast_nonstrict_to_real32(out_value, obj) result(ierror) + real(kind=real32), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + ierror = cast(out_value, obj, .false.) +end function + +function cast_to_real64(out_value, obj) result(ierror) + real(kind=real64), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_float(obj)) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to real(kind=real64).") + endif +end function + +function cast_to_real64_flex(out_value, obj, strict) result(ierror) + real(kind=real64), intent(out) :: out_value + class(object), intent(in) :: obj + logical, intent(in) :: strict + integer(kind=C_INT) :: ierror + + if (.not. strict) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = cast_to_real64(out_value, obj) + endif +end function + +function cast_nonstrict_to_real64(out_value, obj) result(ierror) + real(kind=real64), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + ierror = cast(out_value, obj, .false.) +end function + +function cast_to_complex_real32(out_value, obj) result(ierror) + complex(kind=real32), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_complex(obj)) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to complex(kind=real32).") + endif +end function + +function cast_to_complex_real32_flex(out_value, obj, strict) result(ierror) + complex(kind=real32), intent(out) :: out_value + class(object), intent(in) :: obj + logical, intent(in) :: strict + integer(kind=C_INT) :: ierror + + if (.not. strict) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = cast_to_complex_real32(out_value, obj) + endif +end function + +function cast_nonstrict_to_complex_real32(out_value, obj) result(ierror) + complex(kind=real32), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + ierror = cast(out_value, obj, .false.) +end function + +function cast_to_complex_real64(out_value, obj) result(ierror) + complex(kind=real64), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_complex(obj)) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to complex(kind=real64).") + endif +end function + +function cast_to_complex_real64_flex(out_value, obj, strict) result(ierror) + complex(kind=real64), intent(out) :: out_value + class(object), intent(in) :: obj + logical, intent(in) :: strict + integer(kind=C_INT) :: ierror + + if (.not. strict) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = cast_to_complex_real64(out_value, obj) + endif +end function + +function cast_nonstrict_to_complex_real64(out_value, obj) result(ierror) + complex(kind=real64), intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + ierror = cast(out_value, obj, .false.) +end function + +function cast_to_logical(out_value, obj) result(ierror) + logical, intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_bool(obj)) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to logical.") + endif +end function + +function cast_to_logical_flex(out_value, obj, strict) result(ierror) + logical, intent(out) :: out_value + class(object), intent(in) :: obj + logical, intent(in) :: strict + integer(kind=C_INT) :: ierror + + if (.not. strict) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = cast_to_logical(out_value, obj) + endif +end function + +function cast_nonstrict_to_logical(out_value, obj) result(ierror) + logical, intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + ierror = cast(out_value, obj, .false.) +end function + + +! casts to/from strings +function cast_to_chars(out_value, obj) result(ierror) + character(kind=C_CHAR, len=:), allocatable, intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_str(obj) .or. is_bytes(obj) .or. is_unicode(obj)) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to character(kind=C_CHAR, len=:).") + endif +end function + +function cast_from_chars(obj, in_value) result(ierror) + type(object), intent(out) :: obj + character(kind=C_CHAR, len=*), intent(in) :: in_value + integer(kind=C_INT) :: ierror + + ierror = box_value(obj%py_object, in_value) +end function + +function cast_from_char_1d(obj, in_value) result(ierror) + type(object), intent(out) :: obj + character(kind=C_CHAR), dimension(:), intent(in) :: in_value + integer(kind=C_INT) :: ierror + + ierror = box_value(obj%py_object, in_value) +end function + +function cast_to_char_1d(out_value, obj) result(ierror) + character(kind=C_CHAR), dimension(:), pointer :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + if (is_str(obj) .or. is_bytes(obj) .or. is_unicode(obj)) then + ierror = unbox_value(out_value, obj%py_object) + else + ierror = EXCEPTION_ERROR + call raise_exception(TypeError, "forpy: Could not cast to character(kind=C_CHAR), dimension(:), pointer.") + endif +end function + +function cast_nonstrict_to_chars(out_value, obj) result(ierror) + character(kind=C_CHAR, len=:), allocatable, intent(out) :: out_value + class(object), intent(in) :: obj + integer(kind=C_INT) :: ierror + + type(c_ptr) :: str_obj + + if (is_str(obj) .or. is_bytes(obj) .or. is_unicode(obj)) then + ierror = unbox_value(out_value, obj%py_object) + return + endif + + str_obj = PyObject_Str(obj%py_object) + + if (.not. c_associated(str_obj)) then + ierror = EXCEPTION_ERROR + return + endif + + ierror = unbox_value(out_value, str_obj) + call Py_DecRef(str_obj) +end function + +! casting scalar Fortran types into Python objects + +function cast_from_int32(obj, in_value) result(ierror) + type(object), intent(out) :: obj + integer(kind=int32), intent(in) :: in_value + integer(kind=C_INT) :: ierror + + ierror = box_value(obj%py_object, in_value) +end function + +function cast_from_int64(obj, in_value) result(ierror) + type(object), intent(out) :: obj + integer(kind=int64), intent(in) :: in_value + integer(kind=C_INT) :: ierror + + ierror = box_value(obj%py_object, in_value) +end function + +function cast_from_real32(obj, in_value) result(ierror) + type(object), intent(out) :: obj + real(kind=real32), intent(in) :: in_value + integer(kind=C_INT) :: ierror + + ierror = box_value(obj%py_object, in_value) +end function + +function cast_from_real64(obj, in_value) result(ierror) + type(object), intent(out) :: obj + real(kind=real64), intent(in) :: in_value + integer(kind=C_INT) :: ierror + + ierror = box_value(obj%py_object, in_value) +end function + +function cast_from_complex_real32(obj, in_value) result(ierror) + type(object), intent(out) :: obj + complex(kind=real32), intent(in) :: in_value + integer(kind=C_INT) :: ierror + + ierror = box_value(obj%py_object, in_value) +end function + +function cast_from_complex_real64(obj, in_value) result(ierror) + type(object), intent(out) :: obj + complex(kind=real64), intent(in) :: in_value + integer(kind=C_INT) :: ierror + + ierror = box_value(obj%py_object, in_value) +end function + +function cast_from_logical(obj, in_value) result(ierror) + type(object), intent(out) :: obj + logical, intent(in) :: in_value + integer(kind=C_INT) :: ierror + + ierror = box_value(obj%py_object, in_value) +end function + + +!=============================================================================== +! Assignment with Python semantics +!=============================================================================== + +! Usage: call assign_py(lhs, rhs) + +!> Equivalent to the following Python code: lhs = rhs +!> +!> do not forget to destroy lhs after usage +subroutine assign_py_object(lhs, rhs) + type(object), intent(out) :: lhs + class(object), intent(in) :: rhs + + lhs%py_object = rhs%py_object + call Py_IncRef(lhs%py_object) +end subroutine + +!> Equivalent to the following Python code: lhs = rhs +!> +!> do not forget to destroy lhs after usage +subroutine assign_py_list(lhs, rhs) + type(list), intent(out) :: lhs + class(list), intent(in) :: rhs + + lhs%py_object = rhs%py_object + call Py_IncRef(lhs%py_object) +end subroutine + +!> Equivalent to the following Python code: lhs = rhs +!> +!> do not forget to destroy lhs after usage +subroutine assign_py_tuple(lhs, rhs) + type(tuple), intent(out) :: lhs + class(tuple), intent(in) :: rhs + + lhs%py_object = rhs%py_object + call Py_IncRef(lhs%py_object) +end subroutine + +!> Equivalent to the following Python code: lhs = rhs +!> +!> do not forget to destroy lhs after usage +subroutine assign_py_dict(lhs, rhs) + type(dict), intent(out) :: lhs + class(dict), intent(in) :: rhs + + lhs%py_object = rhs%py_object + call Py_IncRef(lhs%py_object) +end subroutine + +!> Equivalent to the following Python code: lhs = rhs +!> +!> do not forget to destroy lhs after usage +subroutine assign_py_ndarray(lhs, rhs) + type(ndarray), intent(out) :: lhs + class(ndarray), intent(in) :: rhs + + lhs%py_object = rhs%py_object + call Py_IncRef(lhs%py_object) +end subroutine + +!> Equivalent to the following Python code: lhs = rhs +!> +!> do not forget to destroy lhs after usage +subroutine assign_py_type_py(lhs, rhs) + type(type_py), intent(out) :: lhs + class(type_py), intent(in) :: rhs + + lhs%py_object = rhs%py_object + call Py_IncRef(lhs%py_object) +end subroutine + +!> Equivalent to the following Python code: lhs = rhs +!> +!> do not forget to destroy lhs after usage +subroutine assign_py_module_py(lhs, rhs) + type(module_py), intent(out) :: lhs + class(module_py), intent(in) :: rhs + + lhs%py_object = rhs%py_object + call Py_IncRef(lhs%py_object) +end subroutine + +!> Equivalent to the following Python code: lhs = rhs +!> +!> do not forget to destroy lhs after usage +subroutine assign_py_NoneType(lhs, rhs) + type(NoneType), intent(out) :: lhs + class(NoneType), intent(in) :: rhs + + lhs%py_object = rhs%py_object + call Py_IncRef(lhs%py_object) +end subroutine + + +!=============================================================================== +! Exception handling +!=============================================================================== + +!> Checks if a certain type of exception has occurred. +!> +!> Example: flag = exception_matches(KeyError) +!> Returns .false. if no exception has occurred. +function exception_matches(exc) result(is_match) + class(object), intent(in) :: exc + logical :: is_match + + type(c_ptr) :: err_obj + + err_obj = PyErr_Occurred() + + if (c_associated(err_obj) .and. c_associated(exc%py_object)) then + is_match = (PyErr_GivenExceptionMatches(err_obj, exc%py_object) == 1) + return + endif + + is_match = .false. +end function + +!> Clears an exception. +!> +!> No effect if no exception happened. Must be called +!> after handling an exception, otherwise +!> future forpy/Python operations can fail in strange ways. +subroutine err_clear() + call PyErr_Clear() +end subroutine + +!> Prints and clears exception. If no exception has occurred, does nothing. +subroutine err_print() + type(c_ptr) :: err_obj + err_obj = PyErr_Occurred() + ! check if there really is an error, otherwise call to PyErr_Print is fatal + if (c_associated(err_obj)) then + call PyErr_Print() + endif +end subroutine + +!> returns .true. if an exception has occurred +function have_exception() + logical :: have_exception + + type(c_ptr) :: err_obj + err_obj = PyErr_Occurred() + have_exception = c_associated(err_obj) +end function + +!> raises an exception +subroutine raise_exception(exc_type, message) + !> The exception to raise. + !> + !> Example: call raise_exception(ValueError, "bad value") + class(object), intent(in) :: exc_type + character(kind=C_CHAR, len=*), intent(in) :: message + + call PyErr_SetString(exc_type%py_object, message // C_NULL_CHAR) +end subroutine + +!======================================================================= +! Python extension development +!======================================================================= + +function PythonModule_init(self, module_name, doc_string, method_table) result(module_ptr) + class(PythonModule), intent(inout) :: self + !> Name of the Python extension module. + character(kind=C_CHAR, len=*), intent(in) :: module_name + !> Doc string for the Python extension module. + character(kind=C_CHAR, len=*), intent(in) :: doc_string + !> Table of methods of the Python extension module. + type(PythonMethodTable), intent(in) :: method_table + type(c_ptr) :: module_ptr + + integer(kind=C_INT), parameter :: PYTHON_API_VERSION = 1013_C_INT !api-version is 1013 since 2006 and still is in 2018 + + module_ptr = C_NULL_PTR + self%module_ptr = C_NULL_PTR + + allocate(self%module_def) ! never deallocated, for reasons given in PythonMethodTable_init + + self%module_def = PyModuleDef(PyModuleDef_Base(1_PY_SSIZE_T_KIND, C_NULL_PTR, C_NULL_PTR, & + 0_PY_SSIZE_T_KIND, C_NULL_PTR), & + C_NULL_PTR, C_NULL_PTR, -1_PY_SSIZE_T_KIND, C_NULL_PTR, C_NULL_PTR, & + C_NULL_FUNPTR, C_NULL_FUNPTR, C_NULL_FUNPTR) + + allocate(character(kind=C_CHAR,len=len(module_name)+1) :: self%module_name) + self%module_name = module_name // C_NULL_CHAR + allocate(character(kind=C_CHAR,len=len(doc_string)+1) :: self%doc_string) + self%doc_string = doc_string // C_NULL_CHAR + + self%module_def%m_methods = method_table%get_method_table() + self%module_def%m_name = c_loc(self%module_name) + self%module_def%m_doc = c_loc(self%doc_string) + +#ifndef PYTHON2 + module_ptr = PyModule_Create2(c_loc(self%module_def), PYTHON_API_VERSION) +#else + module_ptr = Py_InitModule4(self%module_name, self%module_def%m_methods, self%doc_string, C_NULL_PTR, PYTHON_API_VERSION) +#endif + + self%module_ptr = module_ptr +end function + +!> add an object as a member to a module +function PythonModule_add_object(self, object_name, obj) result(ierror) + class(PythonModule), intent(inout) :: self + !> Name of the module member. It can be accessed by module_name.object_name in Python. + character(kind=C_CHAR, len=*), intent(in) :: object_name + !> The object to add as a member to the module. + class(object), intent(in) :: obj + !> Error code, 0 on success. + integer(kind=C_INT) :: ierror + + call Py_IncRef(obj%py_object) !PyModule_AddObject steals a reference + ierror = PyModule_AddObject(self%module_ptr, object_name // C_NULL_CHAR, obj%py_object) +end function + +subroutine PythonMethodTable_init(self, num_methods) + class(PythonMethodTable), intent(inout) :: self + !> The number of methods your Python module shall have. + integer, intent(in) :: num_methods + + integer :: ii + self%num_methods = num_methods + self%method_count = 0 + ! These are never deallocated + ! not a big problem, since "de-importing" modules in Python is unusual and + ! sometimes impossible. There exist kind of a finish method, so this could be a TODO + allocate(self%methods(num_methods+1)) !need extra space for sentinel entry + allocate(self%strings(num_methods)) + + do ii = 1, num_methods + 1 + ! at the end of methods array there has to be this sentinel value + ! just to be safe, initialise complete method array with it + self%methods(ii) = PyMethodDef(C_NULL_PTR, C_NULL_FUNPTR, 0_C_INT, C_NULL_PTR) + enddo +end subroutine + +subroutine PythonMethodTable_add_method(self, method_name, doc_string, flags, method_funptr) + class(PythonMethodTable), intent(inout) :: self + !> Name of the Python method. + character(kind=C_CHAR, len=*), intent(in) :: method_name + !> Doc string for the Python method + character(kind=C_CHAR, len=*), intent(in) :: doc_string + !> Controls which kind of arguments the Python method shall take. + !> + !> use flags=METH_VARARGS if method shall take only arguments. + !> use flags=METH_KWARGS if method shall take only keyword args. + !> use flags=METH_VARARGS+METH_KWARGS if method shall take both arguments and keyword args. + !> use flags=METH_NOARGS if method shall take no arguments. + integer(kind=C_INT), intent(in) :: flags + !> Function pointer to the Fortran implementation of the method. + !> + !> Use C_FUNLOC() to get method_funptr + !> The Fortran function must take "TYPE(c_ptr), VALUE" arguments (number depends on what arguments it takes) + !> and have a type(c_ptr) return value. + !> E. g. if flags=METH_VARARGS+METH_KWARGS, one needs 3 arguments + !> (1st arg: module c_ptr, 2nd: arguments c_ptr, 3rd: kwargs c_ptr) + !> use [[unsafe_cast_from_c_ptr]] to cast 2nd argument to a tuple + !> and 3rd argument to a dict. + !> The function must return a Python object type(c_ptr). + !> Use object%get_c_ptr() to retrieve the c_ptr from a forpy object. + type(c_funptr), intent(in) :: method_funptr + + integer :: ind + type(c_ptr) :: method_name_loc, doc_string_loc + + if (self%method_count >= self%num_methods) then + call raise_exception(ImportError, "forpy: Could not add method. Increase num_methods in PythonMethodTable%init") + return + endif + + ind = self%method_count + 1 + + allocate(character(kind=C_CHAR,len=len(method_name)+1) :: self%strings(ind)%method_name) + self%strings(ind)%method_name = method_name // C_NULL_CHAR + + allocate(character(kind=C_CHAR,len=len(doc_string)+1) :: self%strings(ind)%doc_string) + self%strings(ind)%doc_string = doc_string // C_NULL_CHAR + + method_name_loc = c_loc(self%strings(ind)%method_name) + doc_string_loc = c_loc(self%strings(ind)%doc_string) + + self%methods(ind) = PyMethodDef(method_name_loc, method_funptr, flags, doc_string_loc) + self%method_count = self%method_count + 1 +end subroutine + +function PythonMethodTable_get(self) result(m) + class(PythonMethodTable), intent(in) :: self + type(c_ptr) :: m + m = c_loc(self%methods) +end function + +!> Creates an [[object]] from a type(c_ptr), no type checks +!> +!> use with care, use only for developing Python extensions +!> created object 'obj' has to be cleaned up by calling obj%destroy +subroutine unsafe_cast_from_c_ptr(obj, ptr) + !> The created Python object. + class(object), intent(out) :: obj + !> C pointer to cast from + type(c_ptr), intent(in) :: ptr + + call Py_IncRef(ptr) + obj%py_object = ptr +end subroutine + +!======================================================================= +! Tools +!======================================================================= + +!> Python's print function. +function print_py(obj, kwargs) result(ierror) + !> Object to print. + class(object), intent(in) :: obj + !> Optional dict of keyword arguments + class(dict), intent(in), optional :: kwargs + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + type(c_ptr) :: builtin_dict, tmp + type(object) :: print_fun + type(tuple) :: args + + builtin_dict = PyEval_GetBuiltins() ! borrowed ref - do not decref + if (.not. c_associated(builtin_dict)) then + ierror = EXCEPTION_ERROR + return + endif + + tmp = PyDict_GetItemString(builtin_dict, "print" // C_NULL_CHAR) !borrowed ref + print_fun%py_object = tmp + + ierror = tuple_create(args, 1) + if (ierror /= 0_C_INT) return + + ierror = args%setitem(0, obj) + if (ierror /= 0_C_INT) then + call args%destroy + endif + + if (present(kwargs)) then + ierror = call_py_noret(print_fun, args, kwargs) + else + ierror = call_py_noret(print_fun, args) + endif + + call args%destroy + ! do not destroy print_fun: borrowed ref + +end function + +!> Getting the list of module search paths: sys.path +!> +!> Can be used to append additional directories, where modules shall be searched +function get_sys_path(paths) result(ierror) + !> Output: list of module search paths + type(list), intent(out) :: paths + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + type(object) :: tmp + + tmp%py_object = PySys_GetObject("path" // C_NULL_CHAR) + ierror = cast(paths, tmp) + ! not destroying tmp, because PySys_GetObject returns borrowed reference +end function + +!> Run Python code that is given as string. +function run_string(string) result(ierror) + !> Python code to run. + character(kind=C_CHAR, len=*), intent(in) :: string + !> Error code, 0 on success + integer(kind=C_INT) :: ierror + + integer :: length + length = len(string) + ! check if null-byte is at and of string, if not append it, which can + ! be expensive + if (string(length:length) == C_NULL_CHAR) then + ierror = PyRun_SimpleString(string) + else + ierror = PyRun_SimpleString(string // C_NULL_CHAR) + endif +end function + +end module diff --git a/src/shared/pytorch/README.md b/src/shared/pytorch/README.md new file mode 100644 index 0000000..98fa439 --- /dev/null +++ b/src/shared/pytorch/README.md @@ -0,0 +1,9 @@ +Code from Dave Connelly and Minah Yang. +Pytorch neural net for gravity wave parameterization. + +There are 3 relevant files: +1. arch_DaveNet.py : This defines the architecture. +2. network_wst.pkl : When loaded via torch, yields a dictionary that contains weights (trained model parameters), means (40-length vector mean of the output), and stds (40-length vector standard deviations of the output) +3. run_emulator_DaveNet.py : Contains python defs MiMA would call. + +I guess 1 & 3 can be combined into one script. I am also attaching a test python script that I used for debugging (test_coupling.py) The two calls at the end of this file is what MiMA needs. diff --git a/src/shared/pytorch/arch_davenet.py b/src/shared/pytorch/arch_davenet.py new file mode 100644 index 0000000..d388a93 --- /dev/null +++ b/src/shared/pytorch/arch_davenet.py @@ -0,0 +1,112 @@ +"""Module defining the pytorch WaveNet architecture for coupling to MiMA. """ +import torch +from torch import nn + + +class WaveNet(nn.Module): + """Neural network architecture following Espinosa et al. (2022).""" + + def __init__( + self, + checkpoint, + n_in: int = 42, + n_out: int = 40, + branch_dims=None, + ) -> None: + """ + Initialize a WaveNet model. + + Parameters + ---------- + checkpoint: dict + dictionary containing weights & statistics. + n_in : int + Number of input features. + n_out : int + Number of output features. + branch_dims : Union[list, None] + List of dimensions of the layers to include in each of the level-specific branches. + + """ + + if branch_dims is None: + branch_dims = [64, 32] + + super().__init__() + + shared = [nn.BatchNorm1d(n_in), nn.Linear(n_in, 256), nn.ReLU()] + for _ in range(4): + shared.extend([nn.Linear(256, 256)]) + shared.extend([nn.ReLU()]) + + shared.extend([nn.Linear(256, branch_dims[0])]) + shared.extend([nn.ReLU()]) + + # All data gets fed through shared, then extra layers defined in branches for each z-level + branches = [] + for _ in range(n_out): + args: list[nn.Module] = [] + for in_features, out_features in zip(branch_dims[:-1], branch_dims[1:]): + args.extend([nn.Linear(in_features, out_features)]) + args.extend([nn.ReLU()]) + + args.extend([nn.Linear(branch_dims[-1], 1)]) + branches.append(nn.Sequential(*args)) + + self.shared = nn.Sequential(*shared) + self.branches = nn.ModuleList(branches) + + self.shared.apply(_xavier_init) + for branch in self.branches: + branch.apply(_xavier_init) + + self.double() + self.means = checkpoint["means"] + self.stds = checkpoint["stds"] + del checkpoint + + def forward(self, wind: torch.Tensor, lat: torch.Tensor, pressure: torch.Tensor) -> torch.Tensor: + """ + Apply the network to a `Tensor` of input features. + + Parameters + ---------- + wind : torch.Tensor + Tensor of of input wind flattened to (n_lat*n_lon, 40). + lat : torch.Tensor + Tensor of of input features flattened to (n_lat*n_lon, 1). + pressure : torch.Tensor + Tensor of of input features flattened to (n_lat*n_lon, 1). + + Returns + ------- + output : torch.Tensor + Tensor of predicted outputs. + + """ + + Z, levels = self.shared(torch.cat((wind, lat, pressure), 1)), [] + + for branch in self.branches: + levels.append(branch(Z).squeeze()) + Y = torch.vstack(levels).T + + # Un-standardize + Y *= self.stds + Y += self.means + return Y + + +def _xavier_init(layer: nn.Module) -> None: + """ + Apply Xavier initialization to a layer if it is an `nn.Linear`. + + Parameters + ---------- + layer : nn.Module + Linear to potentially initialize. + + """ + + if isinstance(layer, nn.Linear): + nn.init.xavier_uniform_(layer.weight) diff --git a/src/shared/pytorch/arch_davenet_orig.py b/src/shared/pytorch/arch_davenet_orig.py new file mode 100644 index 0000000..1c9838e --- /dev/null +++ b/src/shared/pytorch/arch_davenet_orig.py @@ -0,0 +1,112 @@ +"""Module defining the pytorch WaveNet architecture for coupling to MiMA. """ +import torch +from torch import nn + + +class WaveNet(nn.Module): + """Neural network architecture following Espinosa et al. (2022).""" + + def __init__( + self, + checkpoint, + n_in: int = 42, + n_out: int = 40, + branch_dims=None, + ) -> None: + """ + Initialize a WaveNet model. + + Parameters + ---------- + checkpoint: dict + dictionary containing weights & statistics. + n_in : int + Number of input features. + n_out : int + Number of output features. + branch_dims : Union[list, None] + List of dimensions of the layers to include in each of the level-specific branches. + + """ + + if branch_dims is None: + branch_dims = [64, 32] + + super().__init__() + + shared = [nn.BatchNorm1d(n_in), nn.Linear(n_in, 256), nn.ReLU()] + for _ in range(4): + shared.extend([nn.Linear(256, 256)]) + shared.extend([nn.ReLU()]) + + shared.extend([nn.Linear(256, branch_dims[0])]) + shared.extend([nn.ReLU()]) + + # All data gets fed through shared, then extra layers defined in branches for each z-level + branches = [] + for _ in range(n_out): + args: list[nn.Module] = [] + for in_features, out_features in zip(branch_dims[:-1], branch_dims[1:]): + args.extend([nn.Linear(in_features, out_features)]) + args.extend([nn.ReLU()]) + + args.extend([nn.Linear(branch_dims[-1], 1)]) + branches.append(nn.Sequential(*args)) + + self.shared = nn.Sequential(*shared) + self.branches = nn.ModuleList(branches) + + self.shared.apply(_xavier_init) + for branch in self.branches: + branch.apply(_xavier_init) + + self.double() + self.means = checkpoint["means"] + self.stds = checkpoint["stds"] + del checkpoint + + def forward(self, X: torch.Tensor) -> torch.Tensor: + # def forward(self, wind: torch.Tensor, lat: Tensor, pressure: Tensor) -> torch.Tensor: + """ + Apply the network to a `Tensor` of input features. + + Parameters + ---------- + X : torch.Tensor + Tensor of of input features. + + Returns + ------- + output : torch.Tensor + Tensor of predicted outputs. + + """ + # X = torch.Tensor((nlon*nlat, 42)) + # X[:, :40] = wind + # X[:, 40] = lat + # X[:, 41] = pressure + + Z, levels = self.shared(X), [] + for branch in self.branches: + levels.append(branch(Z).squeeze()) + Y = torch.vstack(levels).T + + # Un-standardize + Y *= self.stds + Y += self.means + return Y + + +def _xavier_init(layer: nn.Module) -> None: + """ + Apply Xavier initialization to a layer if it is an `nn.Linear`. + + Parameters + ---------- + layer : nn.Module + Linear to potentially initialize. + + """ + + if isinstance(layer, nn.Linear): + nn.init.xavier_uniform_(layer.weight) diff --git a/src/shared/pytorch/compare_nets.py b/src/shared/pytorch/compare_nets.py new file mode 100644 index 0000000..c78182b --- /dev/null +++ b/src/shared/pytorch/compare_nets.py @@ -0,0 +1,25 @@ +"""Script to test davenet NN""" +import numpy as np +import run_emulator_davenet as red +import run_emulator_davenet_orig as redo + + +IMAX = 128 +NUM_COL = 4 + + +wind = np.random.randn(IMAX, NUM_COL, 40) +lat = np.random.randn(NUM_COL) +lat_long = np.tile(lat.T, (IMAX, 1)) +ps = np.random.randn(IMAX, NUM_COL) +Y_out = np.zeros((IMAX, NUM_COL, 40)) + +# Initialise and run the model +model = red.initialize() +Y_out = red.compute_reshape_drag(model, wind, lat_long, ps, Y_out, NUM_COL) + +model_o = redo.initialize() +Y_out_o = redo.compute_reshape_drag(model_o, wind, lat, ps, Y_out, NUM_COL) + +print(np.array_equal(Y_out, Y_out_o)) + diff --git a/src/shared/pytorch/network_wst.pkl b/src/shared/pytorch/network_wst.pkl new file mode 100644 index 0000000..705ba68 Binary files /dev/null and b/src/shared/pytorch/network_wst.pkl differ diff --git a/src/shared/pytorch/pt2ts.py b/src/shared/pytorch/pt2ts.py new file mode 100644 index 0000000..839bbe5 --- /dev/null +++ b/src/shared/pytorch/pt2ts.py @@ -0,0 +1,132 @@ +"""Load a pytorch model and convert it to TorchScript.""" +from typing import Optional +import torch + +# FPTLIB-TODO +# Add a module import with your model here: +import run_emulator_davenet as red + + +def script_to_torchscript( + model: torch.nn.Module, filename: Optional[str] = "scripted_model.pt" +) -> None: + """ + Save pyTorch model to TorchScript using scripting. + + Parameters + ---------- + model : torch.NN.Module + a pyTorch model + filename : str + name of file to save to + """ + # FIXME: torch.jit.optimize_for_inference() when PyTorch issue #81085 is resolved + scripted_model = torch.jit.script(model) + print(scripted_model.code) + scripted_model.save(filename) + + +def trace_to_torchscript( + model: torch.nn.Module, + dummy_input: torch.Tensor, + filename: Optional[str] = "traced_model.pt", +) -> None: + """ + Save pyTorch model to TorchScript using tracing. + + Parameters + ---------- + model : torch.NN.Module + a pyTorch model + dummy_input : torch.Tensor + appropriate size Tensor to act as input to model + filename : str + name of file to save to + """ + # FIXME: torch.jit.optimize_for_inference() when PyTorch issue #81085 is resolved + traced_model = torch.jit.trace(model, dummy_input) + # traced_model.save(filename) + frozen_model = torch.jit.freeze(traced_model) + ## print(frozen_model.graph) + ## print(frozen_model.code) + frozen_model.save(filename) + + +def load_torchscript(filename: Optional[str] = "saved_model.pth") -> torch.nn.Module: + """ + Load a TorchScript from file. + + Parameters + ---------- + filename : str + name of file containing TorchScript model + """ + model = torch.jit.load(filename) + + return model + + +if __name__ == "__main__": + # FPTLIB-TODO + # Load a pre-trained PyTorch model + # Insert code here to load your model from file as `trained_model`: + trained_model = red.initialize() + + # Switch-off some specific layers/parts of the model that behave + # differently during training and inference. + # This may have been done by the user already, so just make sure here. + trained_model.eval() + + # FPTLIB-TODO + # Generate a dummy input Tensor `dummy_input` to the model of appropriate size. + # trained_model_dummy_input = torch.ones((512, 42)) + trained_model_dummy_input_u = torch.ones((512, 40), dtype=torch.float64) + trained_model_dummy_input_l = torch.ones((512, 1), dtype=torch.float64) + trained_model_dummy_input_p = torch.ones((512, 1), dtype=torch.float64) + + # Run model over dummy input + # If something isn't working This will generate an error + trained_model_dummy_output = trained_model(trained_model_dummy_input_u, + trained_model_dummy_input_l, + trained_model_dummy_input_p, + ) + + # FPTLIB-TODO + # If you want to save for inference on GPU uncomment the following 4 lines: + # device = torch.device('cuda') + # model = model.to(device) + # model.eval() + # dummy_input = dummy_input.to(device) + + # FPTLIB-TODO + # Set the name of the file you want to save the torchscript model to + saved_ts_filename = "saved_model.pth" + + # FPTLIB-TODO + # Save the pytorch model using either scripting (recommended where possible) or tracing + # ----------- + # Scripting + # ----------- + script_to_torchscript(trained_model, filename=saved_ts_filename) + + # ----------- + # Tracing + # ----------- + # trace_to_torchscript(trained_model, trained_model_dummy_input, filename=saved_ts_filename) + + # Load torchscript and run model as a test + testing_input_u = 2.0 * trained_model_dummy_input_u + testing_input_l = 2.0 * trained_model_dummy_input_l + testing_input_p = 2.0 * trained_model_dummy_input_p + trained_model_testing_output = trained_model(testing_input_u, testing_input_l, testing_input_p) + ts_model = load_torchscript(filename=saved_ts_filename) + ts_model_output = ts_model(testing_input_u, testing_input_l, testing_input_p) + + if torch.all(ts_model_output.eq(trained_model_testing_output)): + print("Saved TorchScript model working as expected in a basic test.") + print("Users should perform further validation as appropriate.") + else: + raise RuntimeError( + "Saved Torchscript model is not performing as expected.\n" + "Consider using scripting if you used tracing, or investigate further." + ) diff --git a/src/shared/pytorch/run_emulator_davenet.py b/src/shared/pytorch/run_emulator_davenet.py new file mode 100644 index 0000000..754d32d --- /dev/null +++ b/src/shared/pytorch/run_emulator_davenet.py @@ -0,0 +1,81 @@ +""" +Contains all python commands MiMA will use. + +It needs in the same directory as `arch_DaveNet.py` which describes the +model architecture, and `network_wst.pkl` which contains the model weights. +""" +from torch import load, device, no_grad, reshape, zeros, tensor, float64 +import arch_davenet as m + + +# Initialize everything +def initialize(path_weights_stats="network_wst.pkl"): + """ + Initialize a WaveNet model and load weights. + + Parameters + __________ + path_weights_stats : pickled object that contains weights and statistics (means and stds). + + """ + + device_str = "cpu" + checkpoint = load(path_weights_stats, map_location=device(device_str)) + model = m.WaveNet(checkpoint).to(device_str) + + # Load weights and set to evaluation mode. + model.load_state_dict(checkpoint["weights"]) + model.eval() + return model + + +# Compute drag +def compute_reshape_drag(*args): + """ + Compute the drag from inputs using a neural net. + + Takes in input arguments passed from MiMA and outputs drag in shape desired by MiMA. + Reshaping & porting to torch.tensor type, and applying model.forward is performed. + + Parameters + __________ + model : nn.Module + WaveNet model ready to be deployed. + wind : + U or V (128, num_col, 40) + lat : + latitudes (num_col) + p_surf : + surface pressure (128, num_col) + Y_out : + output prellocated in MiMA (128, num_col, 40) + num_col : + # of latitudes on this proc + + Returns + ------- + Y_out : + Results to be returned to MiMA + """ + model, wind, lat, p_surf, Y_out, num_col = args + + # Reshape and put all input variables together [wind, lat, p_surf] + wind_T = tensor(wind) + + # lat_T = zeros((imax * num_col, 1), dtype=float64) + lat_T = tensor(lat) + + # pressure_T = zeros((imax * num_col, 1), dtype=float64) + pressure_T = tensor(p_surf) + + # Apply model. + with no_grad(): + # Ensure evaluation mode (leave training mode and stop using current batch stats) + # model.eval() # Set during initialisation + assert model.training is False + temp = model(wind_T, pressure_T, lat_T) + + # Place in output array for MiMA. + Y_out[:, :] = temp + + return Y_out diff --git a/src/shared/pytorch/run_emulator_davenet_orig.py b/src/shared/pytorch/run_emulator_davenet_orig.py new file mode 100644 index 0000000..6c5beff --- /dev/null +++ b/src/shared/pytorch/run_emulator_davenet_orig.py @@ -0,0 +1,88 @@ +""" +Contains all python commands MiMA will use. + +It needs in the same directory as `arch_DaveNet.py` which describes the +model architecture, and `network_wst.pkl` which contains the model weights. +""" +from torch import load, device, no_grad, reshape, zeros, tensor, float64 +import arch_davenet_orig as m + + +# Initialize everything +def initialize(path_weights_stats="network_wst.pkl"): + """ + Initialize a WaveNet model and load weights. + + Parameters + __________ + path_weights_stats : pickled object that contains weights and statistics (means and stds). + + """ + + device_str = "cpu" + checkpoint = load(path_weights_stats, map_location=device(device_str)) + model = m.WaveNet(checkpoint).to(device_str) + + # Load weights and set to evaluation mode. + model.load_state_dict(checkpoint["weights"]) + model.eval() + del checkpoint + return model + + +# Compute drag +def compute_reshape_drag(*args): + """ + Compute the drag from inputs using a neural net. + + Takes in input arguments passed from MiMA and outputs drag in shape desired by MiMA. + Reshaping & porting to torch.tensor type, and applying model.forward is performed. + + Parameters + __________ + model : nn.Module + WaveNet model ready to be deployed. + wind : + U or V (128, num_col, 40) + lat : + latitudes (num_col) + p_surf : + surface pressure (128, num_col) + Y_out : + output prellocated in MiMA (128, num_col, 40) + num_col : + # of latitudes on this proc + + Returns + ------- + Y_out : + Results to be returned to MiMA + """ + model, wind, lat, p_surf, Y_out, num_col = args + imax = 128 + + # Reshape and put all input variables together [wind, lat, p_surf] + X = zeros((imax * num_col, 42), dtype=float64) + X[:, :40] = reshape( + tensor(wind), (imax * num_col, 40) + ) # wind[i,j,:] is now at X[i*num_col+j,:40] + + for i in range(num_col): + X[i::num_col, 40] = lat[i] # lat[j] is at X[j::num_col,40]. + + X[:, 41] = reshape( + tensor(p_surf), (imax * num_col,) + ) # p_surf[i,j] is now at X[i*num_col+j,41]. + + # Apply model. + with no_grad(): + # Ensure evaluation mode (leave training mode and stop using current batch stats) + # model.eval() # Set during initialisation + assert model.training is False + temp = model(X) + + # Reshape into what MiMA needs. + # Y_out[i,j,:] was temp[i*num_col+j,:]. + Y_out[:, :, :] = reshape(temp, (imax, num_col, 40)) + del temp + return Y_out diff --git a/src/shared/pytorch/test_coupling.py b/src/shared/pytorch/test_coupling.py new file mode 100644 index 0000000..4e520cc --- /dev/null +++ b/src/shared/pytorch/test_coupling.py @@ -0,0 +1,16 @@ +"""Script to test davenet NN""" +import numpy as np +import run_emulator_davenet as red + + +IMAX = 128 +NUM_COL = 4 + +wind = np.random.randn(IMAX, NUM_COL, 40) +lat = np.random.randn(NUM_COL) +ps = np.random.randn(IMAX, NUM_COL) +Y_out = np.zeros((IMAX, NUM_COL, 40)) + +# Initialise and run the model +model = red.initialize() +Y_out = red.compute_reshape_drag(model, wind, lat, ps, Y_out, NUM_COL) diff --git a/src/shared/tensorflow/README.md b/src/shared/tensorflow/README.md new file mode 100644 index 0000000..e2531a5 --- /dev/null +++ b/src/shared/tensorflow/README.md @@ -0,0 +1,18 @@ +A script that takes the "checkpoint" file created when the code in `../pytorch` +is run and generates a corresponding TensorFlow model. Note that the script +has hard-coded the model layout and structure, so any changes to DaveNet will +have to be propagated here. + +The script then takes the weights and other parameters from the checkpoint file +and applys them to the appropriate places in the TF DaveNet. The resulting +model produces output that is the same as the PyTorch model to within machine +precision. + +``` +Usage: +# Construct an environment, populate with pip -r requirements.txt +python construct-tf-davenet.py [-o output_dir] +``` +The checkpoint file is the one called `network_wst.pkl` in the pytorch directory. +The output directory is where the TF model will be saved. Defaults to +`saved_model`. diff --git a/src/shared/tensorflow/construct-tf-davenet.py b/src/shared/tensorflow/construct-tf-davenet.py new file mode 100644 index 0000000..29beb03 --- /dev/null +++ b/src/shared/tensorflow/construct-tf-davenet.py @@ -0,0 +1,220 @@ +import argparse +from pathlib import Path + +import numpy as np +import torch + +import tensorflow as tf +from tensorflow.keras.layers import BatchNormalization, Dense + + +def main(): + ''' + Construct a TF model that looks like davenet. + ''' + + ap = argparse.ArgumentParser() + ap.add_argument('davenet_file', type=argparse.FileType('rb')) + ap.add_argument( + '--output_dir', + '-o', + type=Path, + default=Path('saved_model') + ) + args = ap.parse_args() + + # First load the PyTorch davenet weights, etc + # checkpoint is a dict, top-level keys are 'weights', 'means', 'stds'. + # Latter two are for final normalisation. + + checkpoint = torch.load(args.davenet_file, + map_location=torch.device('cpu')) + + + the_type = tf.float64 + + # Newest davenet (as modified by Jack Atkinson) has 3 Inputs, + # wind, lat, pressure. + # wind is (:, 40) + # lat is (:, 1) + # pressure is (:, 1) + input_wind = tf.keras.Input( + shape=(40, ), + dtype=the_type, + name='input_wind' + ) + input_lat = tf.keras.Input( + shape=(1, ), + dtype=the_type, + name='input_lat' + ) + input_press = tf.keras.Input( + shape=(1, ), + dtype=the_type, + name='input_press' + ) + inputs = [input_wind, input_lat, input_press] + # concatenate them into a single to feed to original davenet under + # the hood + concatted_input = tf.keras.layers.concatenate( + inputs, + dtype=the_type + ) + prev_layer = BatchNormalization( + dtype=the_type, + epsilon=0.00001, # to match the PyTorch BatchNorm1d default + name='batchnormlayer' + )(concatted_input) + + for i in range(1, 10, 2): # 1, 3, 5, 7, 9 + prev_layer = tf.keras.layers.Dense( + 256, + activation="relu", + dtype=the_type, + kernel_initializer=tf.keras.initializers.GlorotNormal(), + name=f"dense_{i}" + )(prev_layer) + + prev_layer = tf.keras.layers.Dense( + 64, + activation="relu", + dtype=the_type, + kernel_initializer=tf.keras.initializers.GlorotNormal(), + name='dense_11')(prev_layer) + + output_layers = [] + for i in range(40): + nested_prev_layer = prev_layer + for size in [32]: + nested_prev_layer = tf.keras.layers.Dense( + size, + activation="relu", + dtype=the_type, + kernel_initializer=tf.keras.initializers.GlorotNormal(), + name=f"branches.{i}.0", + )(nested_prev_layer) + + # These produce the single value outputs from each branch. + output_layers.append(Dense( + 1, + dtype=the_type, + kernel_initializer=tf.keras.initializers.GlorotNormal(), + name=f"branches.{i}.2", + )(nested_prev_layer)) + + # Concatenate them into one tensor. + concatted_output = tf.keras.layers.concatenate( + output_layers, + dtype=the_type + ) + + # Normalization layer + # davenet does + # + # # Un-standardize + # Y *= self.stds + # Y += self.means + # i.e. it's an inversion of a normalization layer, so we'll set + # invert=True. + + # Oh dear, invert doesn't seem to persist after saving + # (see https://github.com/keras-team/keras/issues/17556). + # Note that Normalization layer has been in keras forever, at least 3 years + # and no one noticed this. + # We'll have to manually invert the mean and variance here. + # Since the Normalization layer will do (x - m) / s + # we need m = -mean / std and s = 1 / std, but layer stores variance + # which is s^2 = 1 / std^2 + + # oh but there's a stddev of zero in there which mucks things up. + # Use np.nan_to_num. + means = np.nan_to_num( + - checkpoint['means'].to('cpu').numpy() / + checkpoint['stds'].to('cpu').numpy() + ) + + variance = np.nan_to_num(np.reciprocal( + checkpoint['stds'].to('cpu').numpy() ** 2)) + normalized_output = tf.keras.layers.Normalization( + invert=False, # see above + dtype=the_type, + mean=means, + variance=variance, + )(concatted_output) + + # Finally declare the model. + model = tf.keras.Model(inputs=inputs, outputs=normalized_output) + + # Most of the options here only apply to training, and are copied from + # Learning-with-GWD-with-MIMA. We do need to compile the Model before we + # save it. + adam_optimizer = tf.keras.optimizers.Adam( + learning_rate=0.0001, + beta_1=0.9, + beta_2=0.999, + epsilon=1e-8, + amsgrad=False, + clipvalue=.1, + ) + model.compile( + optimizer=adam_optimizer, + loss=tf.keras.losses.LogCosh( + reduction=tf.keras.losses.Reduction.SUM_OVER_BATCH_SIZE, + name="log_cosh" + ), + metrics=[ + # Fits to Median: robust to unwanted outliers + tf.keras.metrics.MeanAbsoluteError(name="mean_absolute_error", + dtype=None), + # # Fits to Mean: robust to wanted outliers + tf.keras.metrics.MeanSquaredError(name="mean_squared_error", + dtype=None), + # # Twice diferentiable, combination of MSE and MAE + tf.keras.metrics.LogCoshError(name="logcosh", dtype=None), + # # STD of residuals + tf.keras.metrics.RootMeanSquaredError( + name="root_mean_squared_error", dtype=None + ) + ] + ) + + # Now take the weights from the PyTorch checkpoint and populate our model. + # The mapping was done by manual inspect of the two models. + + # shared.0 is the py.BatchNorm1d layer -> tf.BatchNormalization + chk = checkpoint['weights'] + bnweights = [w.to('cpu').numpy().T for w in ( + chk['shared.0.weight'], + chk['shared.0.bias'], + chk['shared.0.running_mean'], + chk['shared.0.running_var'] + )] + # model.layers[0] is the tf.InputLayer, there is no PyTorch equiv. + model.get_layer('batchnormlayer').set_weights(bnweights) + + # shared.{1,3,5,7,9,11} are the shared Linear layers -> tf.Dense + # shared.{2,4,6,8,10,12} are the ReLU activations. These are not separate + # layers in TF. + for i in range(1, 12, 2): + weights = [w.to('cpu').numpy().T for w in ( + chk[f"shared.{i}.weight"], + chk[f"shared.{i}.bias"] + )] + model.get_layer(f"dense_{i}").set_weights(weights) + + # branch layers Linear -> tf.Dense + for i in range(40): # loop over branches + for j in (0, 2): # layer in branch + weights = [w.to('cpu').numpy().T for w in ( + chk[f"branches.{i}.{j}.weight"], + chk[f"branches.{i}.{j}.bias"] + )] + model.get_layer(f"branches.{i}.{j}").set_weights(weights) + + # Finish + model.summary() + model.save(args.output_dir) + + +if __name__ == '__main__': + main() diff --git a/src/shared/tensorflow/requirements.txt b/src/shared/tensorflow/requirements.txt new file mode 100644 index 0000000..42c1f4b --- /dev/null +++ b/src/shared/tensorflow/requirements.txt @@ -0,0 +1,3 @@ +tensorflow>=2.0 +torch +numpy diff --git a/src/shared/tensorflow/run_tensorflow.py b/src/shared/tensorflow/run_tensorflow.py new file mode 100644 index 0000000..91acdf4 --- /dev/null +++ b/src/shared/tensorflow/run_tensorflow.py @@ -0,0 +1,65 @@ +""" +Contains all python commands MiMA will use. + +This module will use the TensorFlow model. + +""" +import tensorflow as tf + + +# Initialize everything +def initialize(*args, **kwargs): + """ + Initialize a WaveNet model and load weights. + + Parameters + __________ + ignores all parameters + + """ + + model = tf.keras.models.load_model('/home/sjc306/hpc-work/Datawave/MiMA/src/shared/tensorflow/saved_model') + + return model + + +# Compute drag +def compute_reshape_drag(*args): + """ + Compute the drag from inputs using a neural net. + + Takes in input arguments passed from MiMA and outputs drag in shape desired by MiMA. + Reshaping is performed in the calling Fortran. + + Parameters + __________ + model : + WaveNet model ready to be deployed. + wind : + U or V (128, num_col, 40) + lat : + latitudes (num_col) + p_surf : + surface pressure (128, num_col) + Y_out : + output prellocated in MiMA (128, num_col, 40) + num_col : + # of latitudes on this proc + + Returns + ------- + Y_out : + Results to be returned to MiMA + """ + model, wind, lat, p_surf, Y_out, num_col = args + + # Make tensors + # TF will make Tensors itself? + + # Apply model. + temp = model.predict([wind, p_surf, lat], verbose=0) + + # Place in output array for MiMA. + Y_out[:, :] = temp + + return Y_out diff --git a/src/shared/tensorflow/test_py_tf_davenet.py b/src/shared/tensorflow/test_py_tf_davenet.py new file mode 100644 index 0000000..5e954e6 --- /dev/null +++ b/src/shared/tensorflow/test_py_tf_davenet.py @@ -0,0 +1,40 @@ +import torch +import tensorflow as tf +import numpy as np +import sys + +sys.path.append('../pytorch') + +import arch_davenet as m + +def main(): + # Load PyTorch model + checkpoint = torch.load('../pytorch/network_wst.pkl', + map_location=torch.device('cpu')) + pytmodel = m.WaveNet(checkpoint).to('cpu') + + # Load weights and set to evaluation mode. + pytmodel.load_state_dict(checkpoint["weights"]) + pytmodel.eval() + + # Load TF model + tfmodel = tf.keras.models.load_model('saved_model') + + # Generate random inputs + # Guessing at magnitudes + wind = np.random.randn(1,40) * 100 + lat = np.random.randn(1,1) * 6 + press = np.random.randn(1,1) * 10 + inps = [wind, lat, press] + + pyt_inps = [torch.tensor(nd, device='cpu') for nd in inps] + + # Run models, compare + pyt_ans = pytmodel(*pyt_inps) + tf_ans = tfmodel(inps) + + difference = tf_ans - pyt_ans.to('cpu').numpy(force=True) + print(difference) + +if __name__ == '__main__': + main() diff --git a/submit_AD99.icelake b/submit_AD99.icelake new file mode 100755 index 0000000..9bb6cf7 --- /dev/null +++ b/submit_AD99.icelake @@ -0,0 +1,147 @@ +#!/bin/bash +#! +#! Example SLURM job script for Peta4-IceLake (Ice Lake CPUs, HDR200 IB) +#! Last updated: Sat Jul 31 15:39:45 BST 2021 +#! + +#!############################################################# +#!#### Modify the options in this section as appropriate ###### +#!############################################################# + +#! sbatch directives begin here ############################### +#! Name of the job: +#SBATCH -J MiMA +#! Which project should be charged: +#SBATCH -A ICCS-SL3-CPU +#SBATCH -p icelake +#! How many whole nodes should be allocated? +#SBATCH --nodes=1 +#! How many (MPI) tasks will there be in total? (<= nodes*76) +#! The Ice Lake (icelake) nodes have 76 CPUs (cores) each and +#! 3380 MiB of memory per CPU. +#SBATCH --ntasks=32 +#! How much wallclock time will be required? +#SBATCH --time=00:05:00 +#! What types of email messages do you wish to receive? +#SBATCH --mail-type=NONE +#! Uncomment this to prevent the job from being requeued (e.g. if +#! interrupted by node failure or system downtime): +##SBATCH --no-requeue +#! Quality of service i.e. 'QoS' (uncomment for short tests) +#SBATCH --qos=INTR + +#! sbatch directives end here (put any additional directives above this line) + +#! Notes: +#! Charging is determined by cpu number*walltime. +#! The --ntasks value refers to the number of tasks to be launched by SLURM only. This +#! usually equates to the number of MPI tasks launched. Reduce this from nodes*76 if +#! demanded by memory requirements, or if OMP_NUM_THREADS>1. +#! Each task is allocated 1 CPU by default, and each CPU is allocated 3380 MiB +#! of memory. If this is insufficient, also specify +#! --cpus-per-task and/or --mem (the latter specifies MiB per node). + +#! Number of nodes and tasks per node allocated by SLURM (do not change): +numnodes=$SLURM_JOB_NUM_NODES +numtasks=$SLURM_NTASKS +mpi_tasks_per_node=$(echo "$SLURM_TASKS_PER_NODE" | sed -e 's/^\([0-9][0-9]*\).*$/\1/') +#! ############################################################ +#! Modify the settings below to specify the application's environment, location +#! and launch method: + +#! Optionally modify the environment seen by the application +#! (note that SLURM reproduces the environment at submission irrespective of ~/.bashrc): +. /etc/profile.d/modules.sh # Leave this line (enables the module command) +module purge # Removes all modules still loaded +module load rhel8/default-icl # REQUIRED - loads the basic environment + +#! Insert additional module load commands after this line if needed: +module load netcdf-c/4.8.1/intel/intel-oneapi-mpi/sbasfxmz +module load netcdf-fortran/4.5.4/intel/intel-oneapi-mpi/lpmynf72 + +#! Full path to application executable: +application="/home/sjc306/hpc-work/Datawave/MiMA/build-debug-ad/mima.x" + +#! Run options for the application: +options="" + +#! Work directory (i.e. where the job will run): +workdir="/home/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_ad/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory + # in which sbatch is run. + +#! Are you using OpenMP (NB this is unrelated to OpenMPI)? If so increase this +#! safe value to no more than 76: +export OMP_NUM_THREADS=1 + +#! Number of MPI tasks to be started by the application per node and in total (do not change): +np=$[${numnodes}*${mpi_tasks_per_node}] + +#! The following variables define a sensible pinning strategy for Intel MPI tasks - +#! this should be suitable for both pure MPI and hybrid MPI/OpenMP jobs: +export I_MPI_PIN_DOMAIN=omp:compact # Domains are $OMP_NUM_THREADS cores in size +export I_MPI_PIN_ORDER=scatter # Adjacent domains have minimal sharing of caches/sockets +#! Notes: +#! 1. These variables influence Intel MPI only. +#! 2. Domains are non-overlapping sets of cores which map 1-1 to MPI tasks. +#! 3. I_MPI_PIN_PROCESSOR_LIST is ignored if I_MPI_PIN_DOMAIN is set. +#! 4. If MPI tasks perform better when sharing caches/sockets, try I_MPI_PIN_ORDER=compact. + + +#! Uncomment one choice for CMD below (add mpirun/mpiexec options if necessary): + +#! Choose this for a MPI code (possibly using OpenMP) using Intel MPI. +#CMD="mpirun -ppn $mpi_tasks_per_node -np $np $application $options" + +#! Choose this for a pure shared-memory OpenMP parallel program on a single node: +#! (OMP_NUM_THREADS threads will be created): +# CMD="$application $options" +CMD="mpiexec -n $np $application $options" + +#! Choose this for a MPI code (possibly using OpenMP) using OpenMPI: +# CMD="mpirun -npernode $mpi_tasks_per_node -np $np $application $options" + + +############################################################### +### You should not have to change anything below this line #### +############################################################### + +cd $workdir +echo -e "Changed directory to `pwd`.\n" + +echo "Copying /input from ~/MiMA" +cp -r /home/sjc306/hpc-work/Datawave/MiMA/input/* . +echo "Copying input_ad.nml into workdir" +cp /home/sjc306/hpc-work/Datawave/MiMA/input_ad.nml ./input.nml +echo "copying executable" +cp $application . + +echo "Making RESTART directory" +mkdir -p RESTART + +echo "numnodes=" +echo $SLURM_JOB_NUM_NODES +echo "numtasks=" +echo $SLURM_NTASKS +echo "mpi_tasks_per_node=:" +echo $mpi_tasks_per_node + +JOBID=$SLURM_JOB_ID + +echo -e "JobID: $JOBID\n======" +echo "Time: `date`" +echo "Running on master node: `hostname`" +echo "Current directory: `pwd`" + +if [ "$SLURM_JOB_NODELIST" ]; then + #! Create a machine file: + export NODEFILE=`generate_pbs_nodefile` + cat $NODEFILE | uniq > machine.file.$JOBID + echo -e "\nNodes allocated:\n================" + echo `cat machine.file.$JOBID | sed -e 's/\..*$//g'` +fi + +echo -e "\nnumtasks=$numtasks, numnodes=$numnodes, mpi_tasks_per_node=$mpi_tasks_per_node (OMP_NUM_THREADS=$OMP_NUM_THREADS)" + +echo -e "\nExecuting command:\n==================\n$CMD\n" + +eval $CMD diff --git a/submit_FP_PT.icelake b/submit_FP_PT.icelake new file mode 100755 index 0000000..5f4eeb2 --- /dev/null +++ b/submit_FP_PT.icelake @@ -0,0 +1,171 @@ +#!/bin/bash +#! +#! Example SLURM job script for Peta4-IceLake (Ice Lake CPUs, HDR200 IB) +#! Last updated: Sat Jul 31 15:39:45 BST 2021 +#! + +#!############################################################# +#!#### Modify the options in this section as appropriate ###### +#!############################################################# + +#! sbatch directives begin here ############################### +#! Name of the job: +#SBATCH -J MiMA +#! Which project should be charged: +#SBATCH -A ICCS-SL3-CPU +#SBATCH -p icelake +#! How many whole nodes should be allocated? +#SBATCH --nodes=1 +#! How many (MPI) tasks will there be in total? (<= nodes*76) +#! The Ice Lake (icelake) nodes have 76 CPUs (cores) each and +#! 3380 MiB of memory per CPU. +#SBATCH --ntasks=32 +#! How much wallclock time will be required? +#SBATCH --time=00:05:00 +#! What types of email messages do you wish to receive? +#SBATCH --mail-type=NONE +#! Uncomment this to prevent the job from being requeued (e.g. if +#! interrupted by node failure or system downtime): +##SBATCH --no-requeue +#! Quality of service i.e. 'QoS' (uncomment for short tests) +#SBATCH --qos=INTR + +#! sbatch directives end here (put any additional directives above this line) + +#! Notes: +#! Charging is determined by cpu number*walltime. +#! The --ntasks value refers to the number of tasks to be launched by SLURM only. This +#! usually equates to the number of MPI tasks launched. Reduce this from nodes*76 if +#! demanded by memory requirements, or if OMP_NUM_THREADS>1. +#! Each task is allocated 1 CPU by default, and each CPU is allocated 3380 MiB +#! of memory. If this is insufficient, also specify +#! --cpus-per-task and/or --mem (the latter specifies MiB per node). + +#! Number of nodes and tasks per node allocated by SLURM (do not change): +numnodes=$SLURM_JOB_NUM_NODES +numtasks=$SLURM_NTASKS +mpi_tasks_per_node=$(echo "$SLURM_TASKS_PER_NODE" | sed -e 's/^\([0-9][0-9]*\).*$/\1/') +#! ############################################################ +#! Modify the settings below to specify the application's environment, location +#! and launch method: + +#! Optionally modify the environment seen by the application +#! (note that SLURM reproduces the environment at submission irrespective of ~/.bashrc): +. /etc/profile.d/modules.sh # Leave this line (enables the module command) +module purge # Removes all modules still loaded +module load rhel8/default-icl # REQUIRED - loads the basic environment + +#! Insert additional module load commands after this line if needed: +module load netcdf-c/4.8.1/intel/intel-oneapi-mpi/sbasfxmz +module load netcdf-fortran/4.5.4/intel/intel-oneapi-mpi/lpmynf72 + +# Extra module for forpy +module load python/3.11.0-icl + +#! Full path to application executable: +application="/home/sjc306/hpc-work/Datawave/MiMA/build-debug-fp/mima.x" + +#! Run options for the application: +options="" + +#! Work directory (i.e. where the job will run): +workdir="/home/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_fp_pt/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory + # in which sbatch is run. + +#! Are you using OpenMP (NB this is unrelated to OpenMPI)? If so increase this +#! safe value to no more than 76: +export OMP_NUM_THREADS=1 + +#! Number of MPI tasks to be started by the application per node and in total (do not change): +np=$[${numnodes}*${mpi_tasks_per_node}] + +#! The following variables define a sensible pinning strategy for Intel MPI tasks - +#! this should be suitable for both pure MPI and hybrid MPI/OpenMP jobs: +export I_MPI_PIN_DOMAIN=omp:compact # Domains are $OMP_NUM_THREADS cores in size +export I_MPI_PIN_ORDER=scatter # Adjacent domains have minimal sharing of caches/sockets +#! Notes: +#! 1. These variables influence Intel MPI only. +#! 2. Domains are non-overlapping sets of cores which map 1-1 to MPI tasks. +#! 3. I_MPI_PIN_PROCESSOR_LIST is ignored if I_MPI_PIN_DOMAIN is set. +#! 4. If MPI tasks perform better when sharing caches/sockets, try I_MPI_PIN_ORDER=compact. + + +#! Uncomment one choice for CMD below (add mpirun/mpiexec options if necessary): + +#! Choose this for a MPI code (possibly using OpenMP) using Intel MPI. +#CMD="mpirun -ppn $mpi_tasks_per_node -np $np $application $options" + +#! Choose this for a pure shared-memory OpenMP parallel program on a single node: +#! (OMP_NUM_THREADS threads will be created): +# CMD="$application $options" +CMD="mpiexec -n $np $application $options" + +#! Choose this for a MPI code (possibly using OpenMP) using OpenMPI: +# CMD="mpirun -npernode $mpi_tasks_per_node -np $np $application $options" + +# Python environment to load +PYENV_TO_LOAD="/home/sjc306/hpc-work/Datawave/MiMA/src/shared/pytorch/venv" + + +############################################################### +### You should not have to change anything below this line #### +############################################################### + +cd $workdir +echo -e "Changed directory to `pwd`.\n" + +echo "Copying /input from ~/MiMA" +cp -r /home/sjc306/hpc-work/Datawave/MiMA/input/* . +echo "Copying input_fp_pt.nml into workdir" +cp /home/sjc306/hpc-work/Datawave/MiMA/input_fp_pt.nml ./input.nml +echo "copying executable" +cp $application . + +echo "Making RESTART directory" +mkdir -p RESTART + +echo "Loading python environment from $PYENV_TO_LOAD" +source $PYENV_TO_LOAD/bin/activate + +echo "Adding to PYTHONPATH" +export PYTHONPATH=/home/sjc306/hpc-work/Datawave/MiMA/src/shared/pytorch +echo "PYTHONPATH now $PYTHONPATH" + +echo "Copying network_wst.pkl" +cp /home/sjc306/hpc-work/Datawave/MiMA/src/shared/pytorch/network_wst.pkl . + +echo "numnodes=" +echo $SLURM_JOB_NUM_NODES +echo "numtasks=" +echo $SLURM_NTASKS +echo "mpi_tasks_per_node=:" +echo $mpi_tasks_per_node + +JOBID=$SLURM_JOB_ID + +echo -e "JobID: $JOBID\n======" +echo "Time: `date`" +echo "Running on master node: `hostname`" +echo "Current directory: `pwd`" + +if [ "$SLURM_JOB_NODELIST" ]; then + #! Create a machine file: + export NODEFILE=`generate_pbs_nodefile` + cat $NODEFILE | uniq > machine.file.$JOBID + echo -e "\nNodes allocated:\n================" + echo `cat machine.file.$JOBID | sed -e 's/\..*$//g'` +fi + +echo -e "\nnumtasks=$numtasks, numnodes=$numnodes, mpi_tasks_per_node=$mpi_tasks_per_node (OMP_NUM_THREADS=$OMP_NUM_THREADS)" + +echo -e "\nExecuting command:\n==================\n$CMD\n" + +echo 'running test' +cd /home/sjc306/hpc-work/Datawave/forpy_test +eval ./test +cd - + +which python +pip list + +eval $CMD diff --git a/submit_FP_TF.icelake b/submit_FP_TF.icelake new file mode 100755 index 0000000..7dc2366 --- /dev/null +++ b/submit_FP_TF.icelake @@ -0,0 +1,170 @@ +#!/bin/bash +#! +#! Example SLURM job script for Peta4-IceLake (Ice Lake CPUs, HDR200 IB) +#! Last updated: Sat Jul 31 15:39:45 BST 2021 +#! + +#!############################################################# +#!#### Modify the options in this section as appropriate ###### +#!############################################################# + +#! sbatch directives begin here ############################### +#! Name of the job: +#SBATCH -J MiMA +#! Which project should be charged: +#SBATCH -A ICCS-SL3-CPU +#SBATCH -p icelake +#! How many whole nodes should be allocated? +#SBATCH --nodes=1 +#! How many (MPI) tasks will there be in total? (<= nodes*76) +#! The Ice Lake (icelake) nodes have 76 CPUs (cores) each and +#! 3380 MiB of memory per CPU. +#SBATCH --ntasks=32 +#! How much wallclock time will be required? +#SBATCH --time=00:05:00 +#! What types of email messages do you wish to receive? +#SBATCH --mail-type=NONE +#! Uncomment this to prevent the job from being requeued (e.g. if +#! interrupted by node failure or system downtime): +##SBATCH --no-requeue +#! Quality of service i.e. 'QoS' (uncomment for short tests) +#SBATCH --qos=INTR + +#! sbatch directives end here (put any additional directives above this line) + +#! Notes: +#! Charging is determined by cpu number*walltime. +#! The --ntasks value refers to the number of tasks to be launched by SLURM only. This +#! usually equates to the number of MPI tasks launched. Reduce this from nodes*76 if +#! demanded by memory requirements, or if OMP_NUM_THREADS>1. +#! Each task is allocated 1 CPU by default, and each CPU is allocated 3380 MiB +#! of memory. If this is insufficient, also specify +#! --cpus-per-task and/or --mem (the latter specifies MiB per node). + +#! Number of nodes and tasks per node allocated by SLURM (do not change): +numnodes=$SLURM_JOB_NUM_NODES +numtasks=$SLURM_NTASKS +mpi_tasks_per_node=$(echo "$SLURM_TASKS_PER_NODE" | sed -e 's/^\([0-9][0-9]*\).*$/\1/') +#! ############################################################ +#! Modify the settings below to specify the application's environment, location +#! and launch method: + +#! Optionally modify the environment seen by the application +#! (note that SLURM reproduces the environment at submission irrespective of ~/.bashrc): +. /etc/profile.d/modules.sh # Leave this line (enables the module command) +module purge # Removes all modules still loaded +module load rhel8/default-icl # REQUIRED - loads the basic environment + +#! Insert additional module load commands after this line if needed: +module load netcdf-c/4.8.1/intel/intel-oneapi-mpi/sbasfxmz +module load netcdf-fortran/4.5.4/intel/intel-oneapi-mpi/lpmynf72 + +# Extra module for forpy +module load python/3.11.0-icl + +#! Full path to application executable: +application="/home/sjc306/hpc-work/Datawave/MiMA/build-debug-fp/mima.x" + +#! Run options for the application: +options="" + +#! Work directory (i.e. where the job will run): +workdir="/home/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_fp_tf/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory + # in which sbatch is run. + +#! Are you using OpenMP (NB this is unrelated to OpenMPI)? If so increase this +#! safe value to no more than 76: +export OMP_NUM_THREADS=1 + +#! Number of MPI tasks to be started by the application per node and in total (do not change): +np=$[${numnodes}*${mpi_tasks_per_node}] + +#! The following variables define a sensible pinning strategy for Intel MPI tasks - +#! this should be suitable for both pure MPI and hybrid MPI/OpenMP jobs: +export I_MPI_PIN_DOMAIN=omp:compact # Domains are $OMP_NUM_THREADS cores in size +export I_MPI_PIN_ORDER=scatter # Adjacent domains have minimal sharing of caches/sockets +#! Notes: +#! 1. These variables influence Intel MPI only. +#! 2. Domains are non-overlapping sets of cores which map 1-1 to MPI tasks. +#! 3. I_MPI_PIN_PROCESSOR_LIST is ignored if I_MPI_PIN_DOMAIN is set. +#! 4. If MPI tasks perform better when sharing caches/sockets, try I_MPI_PIN_ORDER=compact. + + +#! Uncomment one choice for CMD below (add mpirun/mpiexec options if necessary): + +#! Choose this for a MPI code (possibly using OpenMP) using Intel MPI. +#CMD="mpirun -ppn $mpi_tasks_per_node -np $np $application $options" + +#! Choose this for a pure shared-memory OpenMP parallel program on a single node: +#! (OMP_NUM_THREADS threads will be created): +# CMD="$application $options" +CMD="mpiexec -n $np $application $options" + +#! Choose this for a MPI code (possibly using OpenMP) using OpenMPI: +# CMD="mpirun -npernode $mpi_tasks_per_node -np $np $application $options" + +# Python environment to load +PYENV_TO_LOAD="/home/sjc306/hpc-work/Datawave/MiMA/src/shared/tensorflow/venv" + +# Set hdf5 version check disable? Argh. +export HDF5_DISABLE_VERSION_CHECK=1 + +############################################################### +### You should not have to change anything below this line #### +############################################################### + +cd $workdir +echo -e "Changed directory to `pwd`.\n" + +echo "Copying /input from ~/MiMA" +cp -r /home/sjc306/hpc-work/Datawave/MiMA/input/* . +echo "Copying input_fp_tf.nml into workdir" +cp /home/sjc306/hpc-work/Datawave/MiMA/input_fp_tf.nml ./input.nml +echo "copying executable" +cp $application . + +echo "Making RESTART directory" +mkdir -p RESTART + +echo "Loading python environment from $PYENV_TO_LOAD" +source $PYENV_TO_LOAD/bin/activate + +echo "Adding to PYTHONPATH" +export PYTHONPATH=/home/sjc306/hpc-work/Datawave/MiMA/src/shared/tensorflow +echo "PYTHONPATH now $PYTHONPATH" + +echo "numnodes=" +echo $SLURM_JOB_NUM_NODES +echo "numtasks=" +echo $SLURM_NTASKS +echo "mpi_tasks_per_node=:" +echo $mpi_tasks_per_node + +JOBID=$SLURM_JOB_ID + +echo -e "JobID: $JOBID\n======" +echo "Time: `date`" +echo "Running on master node: `hostname`" +echo "Current directory: `pwd`" + +if [ "$SLURM_JOB_NODELIST" ]; then + #! Create a machine file: + export NODEFILE=`generate_pbs_nodefile` + cat $NODEFILE | uniq > machine.file.$JOBID + echo -e "\nNodes allocated:\n================" + echo `cat machine.file.$JOBID | sed -e 's/\..*$//g'` +fi + +echo -e "\nnumtasks=$numtasks, numnodes=$numnodes, mpi_tasks_per_node=$mpi_tasks_per_node (OMP_NUM_THREADS=$OMP_NUM_THREADS)" + +echo -e "\nExecuting command:\n==================\n$CMD\n" + +echo 'running test' +cd /home/sjc306/hpc-work/Datawave/forpy_test +eval ./test +cd - + +which python +pip list + +eval $CMD diff --git a/submit_PT.icelake b/submit_PT.icelake new file mode 100755 index 0000000..e643668 --- /dev/null +++ b/submit_PT.icelake @@ -0,0 +1,150 @@ +#!/bin/bash +#! +#! Example SLURM job script for Peta4-IceLake (Ice Lake CPUs, HDR200 IB) +#! Last updated: Sat Jul 31 15:39:45 BST 2021 +#! + +#!############################################################# +#!#### Modify the options in this section as appropriate ###### +#!############################################################# + +#! sbatch directives begin here ############################### +#! Name of the job: +#SBATCH -J MiMA +#! Which project should be charged: +#SBATCH -A ICCS-SL3-CPU +#SBATCH -p icelake +#! How many whole nodes should be allocated? +#SBATCH --nodes=1 +#! How many (MPI) tasks will there be in total? (<= nodes*76) +#! The Ice Lake (icelake) nodes have 76 CPUs (cores) each and +#! 3380 MiB of memory per CPU. +#SBATCH --ntasks=32 +#! How much wallclock time will be required? +#SBATCH --time=00:05:00 +#! What types of email messages do you wish to receive? +#SBATCH --mail-type=NONE +#! Uncomment this to prevent the job from being requeued (e.g. if +#! interrupted by node failure or system downtime): +##SBATCH --no-requeue +#! Quality of service i.e. 'QoS' (uncomment for short tests) +#SBATCH --qos=INTR + +#! sbatch directives end here (put any additional directives above this line) + +#! Notes: +#! Charging is determined by cpu number*walltime. +#! The --ntasks value refers to the number of tasks to be launched by SLURM only. This +#! usually equates to the number of MPI tasks launched. Reduce this from nodes*76 if +#! demanded by memory requirements, or if OMP_NUM_THREADS>1. +#! Each task is allocated 1 CPU by default, and each CPU is allocated 3380 MiB +#! of memory. If this is insufficient, also specify +#! --cpus-per-task and/or --mem (the latter specifies MiB per node). + +#! Number of nodes and tasks per node allocated by SLURM (do not change): +numnodes=$SLURM_JOB_NUM_NODES +numtasks=$SLURM_NTASKS +mpi_tasks_per_node=$(echo "$SLURM_TASKS_PER_NODE" | sed -e 's/^\([0-9][0-9]*\).*$/\1/') +#! ############################################################ +#! Modify the settings below to specify the application's environment, location +#! and launch method: + +#! Optionally modify the environment seen by the application +#! (note that SLURM reproduces the environment at submission irrespective of ~/.bashrc): +. /etc/profile.d/modules.sh # Leave this line (enables the module command) +module purge # Removes all modules still loaded +module load rhel8/default-icl # REQUIRED - loads the basic environment + +#! Insert additional module load commands after this line if needed: +module load netcdf-c/4.8.1/intel/intel-oneapi-mpi/sbasfxmz +module load netcdf-fortran/4.5.4/intel/intel-oneapi-mpi/lpmynf72 + +#! Full path to application executable: +application="/home/sjc306/hpc-work/Datawave/MiMA/build-debug-pt/mima.x" + +#! Run options for the application: +options="" + +#! Work directory (i.e. where the job will run): +workdir="/home/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_pt/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory + # in which sbatch is run. + +#! Are you using OpenMP (NB this is unrelated to OpenMPI)? If so increase this +#! safe value to no more than 76: +export OMP_NUM_THREADS=1 + +#! Number of MPI tasks to be started by the application per node and in total (do not change): +np=$[${numnodes}*${mpi_tasks_per_node}] + +#! The following variables define a sensible pinning strategy for Intel MPI tasks - +#! this should be suitable for both pure MPI and hybrid MPI/OpenMP jobs: +export I_MPI_PIN_DOMAIN=omp:compact # Domains are $OMP_NUM_THREADS cores in size +export I_MPI_PIN_ORDER=scatter # Adjacent domains have minimal sharing of caches/sockets +#! Notes: +#! 1. These variables influence Intel MPI only. +#! 2. Domains are non-overlapping sets of cores which map 1-1 to MPI tasks. +#! 3. I_MPI_PIN_PROCESSOR_LIST is ignored if I_MPI_PIN_DOMAIN is set. +#! 4. If MPI tasks perform better when sharing caches/sockets, try I_MPI_PIN_ORDER=compact. + + +#! Uncomment one choice for CMD below (add mpirun/mpiexec options if necessary): + +#! Choose this for a MPI code (possibly using OpenMP) using Intel MPI. +#CMD="mpirun -ppn $mpi_tasks_per_node -np $np $application $options" + +#! Choose this for a pure shared-memory OpenMP parallel program on a single node: +#! (OMP_NUM_THREADS threads will be created): +# CMD="$application $options" +CMD="mpiexec -n $np $application $options" + +#! Choose this for a MPI code (possibly using OpenMP) using OpenMPI: +# CMD="mpirun -npernode $mpi_tasks_per_node -np $np $application $options" + + +############################################################### +### You should not have to change anything below this line #### +############################################################### + +cd $workdir +echo -e "Changed directory to `pwd`.\n" + +echo "Copying /input from ~/MiMA" +cp -r /home/sjc306/hpc-work/Datawave/MiMA/input/* . +echo "Copying input_pt.nml into workdir" +cp /home/sjc306/hpc-work/Datawave/MiMA/input_pt.nml ./input.nml +echo "copying executable" +cp $application . + +echo "Making RESTART directory" +mkdir -p RESTART + +echo "Copying network_wst.pkl" +cp /home/sjc306/hpc-work/Datawave/MiMA/src/shared/pytorch/network_wst.pkl . + +echo "numnodes=" +echo $SLURM_JOB_NUM_NODES +echo "numtasks=" +echo $SLURM_NTASKS +echo "mpi_tasks_per_node=:" +echo $mpi_tasks_per_node + +JOBID=$SLURM_JOB_ID + +echo -e "JobID: $JOBID\n======" +echo "Time: `date`" +echo "Running on master node: `hostname`" +echo "Current directory: `pwd`" + +if [ "$SLURM_JOB_NODELIST" ]; then + #! Create a machine file: + export NODEFILE=`generate_pbs_nodefile` + cat $NODEFILE | uniq > machine.file.$JOBID + echo -e "\nNodes allocated:\n================" + echo `cat machine.file.$JOBID | sed -e 's/\..*$//g'` +fi + +echo -e "\nnumtasks=$numtasks, numnodes=$numnodes, mpi_tasks_per_node=$mpi_tasks_per_node (OMP_NUM_THREADS=$OMP_NUM_THREADS)" + +echo -e "\nExecuting command:\n==================\n$CMD\n" + +eval $CMD diff --git a/submit_TF.icelake b/submit_TF.icelake new file mode 100755 index 0000000..a3b7149 --- /dev/null +++ b/submit_TF.icelake @@ -0,0 +1,147 @@ +#!/bin/bash +#! +#! Example SLURM job script for Peta4-IceLake (Ice Lake CPUs, HDR200 IB) +#! Last updated: Sat Jul 31 15:39:45 BST 2021 +#! + +#!############################################################# +#!#### Modify the options in this section as appropriate ###### +#!############################################################# + +#! sbatch directives begin here ############################### +#! Name of the job: +#SBATCH -J MiMA +#! Which project should be charged: +#SBATCH -A ICCS-SL3-CPU +#SBATCH -p icelake +#! How many whole nodes should be allocated? +#SBATCH --nodes=1 +#! How many (MPI) tasks will there be in total? (<= nodes*76) +#! The Ice Lake (icelake) nodes have 76 CPUs (cores) each and +#! 3380 MiB of memory per CPU. +#SBATCH --ntasks=32 +#! How much wallclock time will be required? +#SBATCH --time=00:05:00 +#! What types of email messages do you wish to receive? +#SBATCH --mail-type=NONE +#! Uncomment this to prevent the job from being requeued (e.g. if +#! interrupted by node failure or system downtime): +##SBATCH --no-requeue +#! Quality of service i.e. 'QoS' (uncomment for short tests) +#SBATCH --qos=INTR + +#! sbatch directives end here (put any additional directives above this line) + +#! Notes: +#! Charging is determined by cpu number*walltime. +#! The --ntasks value refers to the number of tasks to be launched by SLURM only. This +#! usually equates to the number of MPI tasks launched. Reduce this from nodes*76 if +#! demanded by memory requirements, or if OMP_NUM_THREADS>1. +#! Each task is allocated 1 CPU by default, and each CPU is allocated 3380 MiB +#! of memory. If this is insufficient, also specify +#! --cpus-per-task and/or --mem (the latter specifies MiB per node). + +#! Number of nodes and tasks per node allocated by SLURM (do not change): +numnodes=$SLURM_JOB_NUM_NODES +numtasks=$SLURM_NTASKS +mpi_tasks_per_node=$(echo "$SLURM_TASKS_PER_NODE" | sed -e 's/^\([0-9][0-9]*\).*$/\1/') +#! ############################################################ +#! Modify the settings below to specify the application's environment, location +#! and launch method: + +#! Optionally modify the environment seen by the application +#! (note that SLURM reproduces the environment at submission irrespective of ~/.bashrc): +. /etc/profile.d/modules.sh # Leave this line (enables the module command) +module purge # Removes all modules still loaded +module load rhel8/default-icl # REQUIRED - loads the basic environment + +#! Insert additional module load commands after this line if needed: +module load netcdf-c/4.8.1/intel/intel-oneapi-mpi/sbasfxmz +module load netcdf-fortran/4.5.4/intel/intel-oneapi-mpi/lpmynf72 + +#! Full path to application executable: +application="/home/sjc306/hpc-work/Datawave/MiMA/build-debug-tf/mima.x" + +#! Run options for the application: +options="" + +#! Work directory (i.e. where the job will run): +workdir="/home/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_tf/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory + # in which sbatch is run. + +#! Are you using OpenMP (NB this is unrelated to OpenMPI)? If so increase this +#! safe value to no more than 76: +export OMP_NUM_THREADS=1 + +#! Number of MPI tasks to be started by the application per node and in total (do not change): +np=$[${numnodes}*${mpi_tasks_per_node}] + +#! The following variables define a sensible pinning strategy for Intel MPI tasks - +#! this should be suitable for both pure MPI and hybrid MPI/OpenMP jobs: +export I_MPI_PIN_DOMAIN=omp:compact # Domains are $OMP_NUM_THREADS cores in size +export I_MPI_PIN_ORDER=scatter # Adjacent domains have minimal sharing of caches/sockets +#! Notes: +#! 1. These variables influence Intel MPI only. +#! 2. Domains are non-overlapping sets of cores which map 1-1 to MPI tasks. +#! 3. I_MPI_PIN_PROCESSOR_LIST is ignored if I_MPI_PIN_DOMAIN is set. +#! 4. If MPI tasks perform better when sharing caches/sockets, try I_MPI_PIN_ORDER=compact. + + +#! Uncomment one choice for CMD below (add mpirun/mpiexec options if necessary): + +#! Choose this for a MPI code (possibly using OpenMP) using Intel MPI. +#CMD="mpirun -ppn $mpi_tasks_per_node -np $np $application $options" + +#! Choose this for a pure shared-memory OpenMP parallel program on a single node: +#! (OMP_NUM_THREADS threads will be created): +# CMD="$application $options" +CMD="mpiexec -n $np $application $options" + +#! Choose this for a MPI code (possibly using OpenMP) using OpenMPI: +# CMD="mpirun -npernode $mpi_tasks_per_node -np $np $application $options" + + +############################################################### +### You should not have to change anything below this line #### +############################################################### + +cd $workdir +echo -e "Changed directory to `pwd`.\n" + +echo "Copying /input from ~/MiMA" +cp -r /home/sjc306/hpc-work/Datawave/MiMA/input/* . +echo "Copying input_tf.nml into workdir" +cp /home/sjc306/hpc-work/Datawave/MiMA/input_tf.nml ./input.nml +echo "copying executable" +cp $application . + +echo "Making RESTART directory" +mkdir -p RESTART + +echo "numnodes=" +echo $SLURM_JOB_NUM_NODES +echo "numtasks=" +echo $SLURM_NTASKS +echo "mpi_tasks_per_node=:" +echo $mpi_tasks_per_node + +JOBID=$SLURM_JOB_ID + +echo -e "JobID: $JOBID\n======" +echo "Time: `date`" +echo "Running on master node: `hostname`" +echo "Current directory: `pwd`" + +if [ "$SLURM_JOB_NODELIST" ]; then + #! Create a machine file: + export NODEFILE=`generate_pbs_nodefile` + cat $NODEFILE | uniq > machine.file.$JOBID + echo -e "\nNodes allocated:\n================" + echo `cat machine.file.$JOBID | sed -e 's/\..*$//g'` +fi + +echo -e "\nnumtasks=$numtasks, numnodes=$numnodes, mpi_tasks_per_node=$mpi_tasks_per_node (OMP_NUM_THREADS=$OMP_NUM_THREADS)" + +echo -e "\nExecuting command:\n==================\n$CMD\n" + +eval $CMD diff --git a/submit_rel_FP_PT.icelake b/submit_rel_FP_PT.icelake new file mode 100755 index 0000000..de550a0 --- /dev/null +++ b/submit_rel_FP_PT.icelake @@ -0,0 +1,169 @@ +#!/bin/bash +#! +#! Example SLURM job script for Peta4-IceLake (Ice Lake CPUs, HDR200 IB) +#! Last updated: Sat Jul 31 15:39:45 BST 2021 +#! + +#!############################################################# +#!#### Modify the options in this section as appropriate ###### +#!############################################################# + +#! sbatch directives begin here ############################### +#! Name of the job: +#SBATCH -J MiMA +#! Which project should be charged: +#SBATCH -A ICCS-SL3-CPU +#SBATCH -p icelake +#! How many whole nodes should be allocated? +#SBATCH --nodes=1 +#! How many (MPI) tasks will there be in total? (<= nodes*76) +#! The Ice Lake (icelake) nodes have 76 CPUs (cores) each and +#! 3380 MiB of memory per CPU. +#SBATCH --ntasks=32 +#! How much wallclock time will be required? +#SBATCH --time=00:05:00 +#! What types of email messages do you wish to receive? +#SBATCH --mail-type=NONE +#! Uncomment this to prevent the job from being requeued (e.g. if +#! interrupted by node failure or system downtime): +##SBATCH --no-requeue +#! Quality of service i.e. 'QoS' (uncomment for short tests) +#SBATCH --qos=INTR + +#! sbatch directives end here (put any additional directives above this line) + +#! Notes: +#! Charging is determined by cpu number*walltime. +#! The --ntasks value refers to the number of tasks to be launched by SLURM only. This +#! usually equates to the number of MPI tasks launched. Reduce this from nodes*76 if +#! demanded by memory requirements, or if OMP_NUM_THREADS>1. +#! Each task is allocated 1 CPU by default, and each CPU is allocated 3380 MiB +#! of memory. If this is insufficient, also specify +#! --cpus-per-task and/or --mem (the latter specifies MiB per node). + +#! Number of nodes and tasks per node allocated by SLURM (do not change): +numnodes=$SLURM_JOB_NUM_NODES +numtasks=$SLURM_NTASKS +mpi_tasks_per_node=$(echo "$SLURM_TASKS_PER_NODE" | sed -e 's/^\([0-9][0-9]*\).*$/\1/') +#! ############################################################ +#! Modify the settings below to specify the application's environment, location +#! and launch method: + +#! Optionally modify the environment seen by the application +#! (note that SLURM reproduces the environment at submission irrespective of ~/.bashrc): +. /etc/profile.d/modules.sh # Leave this line (enables the module command) +module purge # Removes all modules still loaded +module load rhel8/default-icl # REQUIRED - loads the basic environment + +#! Insert additional module load commands after this line if needed: +module load netcdf-c/4.8.1/intel/intel-oneapi-mpi/sbasfxmz +module load netcdf-fortran/4.5.4/intel/intel-oneapi-mpi/lpmynf72 + +# Extra module for forpy +module load python/3.11.0-icl + +#! Full path to application executable: +application="/home/sjc306/hpc-work/Datawave/MiMA/build-rel-fp/mima.x" + +#! Run options for the application: +options="" + +#! Work directory (i.e. where the job will run): +savedir="/home/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_fp_pt/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory +workdir="/local/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_fp_pt/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory + # in which sbatch is run. + +#! Are you using OpenMP (NB this is unrelated to OpenMPI)? If so increase this +#! safe value to no more than 76: +export OMP_NUM_THREADS=1 + +#! Number of MPI tasks to be started by the application per node and in total (do not change): +np=$[${numnodes}*${mpi_tasks_per_node}] + +#! The following variables define a sensible pinning strategy for Intel MPI tasks - +#! this should be suitable for both pure MPI and hybrid MPI/OpenMP jobs: +export I_MPI_PIN_DOMAIN=omp:compact # Domains are $OMP_NUM_THREADS cores in size +export I_MPI_PIN_ORDER=scatter # Adjacent domains have minimal sharing of caches/sockets +#! Notes: +#! 1. These variables influence Intel MPI only. +#! 2. Domains are non-overlapping sets of cores which map 1-1 to MPI tasks. +#! 3. I_MPI_PIN_PROCESSOR_LIST is ignored if I_MPI_PIN_DOMAIN is set. +#! 4. If MPI tasks perform better when sharing caches/sockets, try I_MPI_PIN_ORDER=compact. + + +#! Uncomment one choice for CMD below (add mpirun/mpiexec options if necessary): + +#! Choose this for a MPI code (possibly using OpenMP) using Intel MPI. +#CMD="mpirun -ppn $mpi_tasks_per_node -np $np $application $options" + +#! Choose this for a pure shared-memory OpenMP parallel program on a single node: +#! (OMP_NUM_THREADS threads will be created): +# CMD="$application $options" +CMD="mpiexec -n $np $application $options" + +#! Choose this for a MPI code (possibly using OpenMP) using OpenMPI: +# CMD="mpirun -npernode $mpi_tasks_per_node -np $np $application $options" + +# Python environment to load +PYENV_TO_LOAD="/home/sjc306/hpc-work/Datawave/MiMA/src/shared/pytorch/venv" + + +############################################################### +### You should not have to change anything below this line #### +############################################################### + +mkdir -p $workdir +rm -r $workdir/* +cd $workdir +echo -e "Changed directory to `pwd`.\n" + +echo "Copying /input from ~/MiMA" +cp -r /home/sjc306/hpc-work/Datawave/MiMA/input/* . +echo "Copying input_fp_pt.nml into workdir" +cp /home/sjc306/hpc-work/Datawave/MiMA/input_fp_pt.nml ./input.nml +echo "copying executable" +cp $application . + +echo "Making RESTART directory" +mkdir -p RESTART + +echo "Loading python environment from $PYENV_TO_LOAD" +source $PYENV_TO_LOAD/bin/activate + +echo "Adding to PYTHONPATH" +export PYTHONPATH=/home/sjc306/hpc-work/Datawave/MiMA/src/shared/pytorch +echo "PYTHONPATH now $PYTHONPATH" + +echo "Copying network_wst.pkl" +cp /home/sjc306/hpc-work/Datawave/MiMA/src/shared/pytorch/network_wst.pkl . + +echo "numnodes=" +echo $SLURM_JOB_NUM_NODES +echo "numtasks=" +echo $SLURM_NTASKS +echo "mpi_tasks_per_node=:" +echo $mpi_tasks_per_node + +JOBID=$SLURM_JOB_ID + +echo -e "JobID: $JOBID\n======" +echo "Time: `date`" +echo "Running on master node: `hostname`" +echo "Current directory: `pwd`" + +if [ "$SLURM_JOB_NODELIST" ]; then + #! Create a machine file: + export NODEFILE=`generate_pbs_nodefile` + cat $NODEFILE | uniq > machine.file.$JOBID + echo -e "\nNodes allocated:\n================" + echo `cat machine.file.$JOBID | sed -e 's/\..*$//g'` +fi + +echo -e "\nnumtasks=$numtasks, numnodes=$numnodes, mpi_tasks_per_node=$mpi_tasks_per_node (OMP_NUM_THREADS=$OMP_NUM_THREADS)" + +echo -e "\nExecuting command:\n==================\n$CMD\n" + +eval $CMD + +echo 'Copying data back' +cp -pr $workdir/* $savedir/ diff --git a/submit_rel_FP_TF.icelake b/submit_rel_FP_TF.icelake new file mode 100755 index 0000000..8edba85 --- /dev/null +++ b/submit_rel_FP_TF.icelake @@ -0,0 +1,168 @@ +#!/bin/bash +#! +#! Example SLURM job script for Peta4-IceLake (Ice Lake CPUs, HDR200 IB) +#! Last updated: Sat Jul 31 15:39:45 BST 2021 +#! + +#!############################################################# +#!#### Modify the options in this section as appropriate ###### +#!############################################################# + +#! sbatch directives begin here ############################### +#! Name of the job: +#SBATCH -J MiMA +#! Which project should be charged: +#SBATCH -A ICCS-SL3-CPU +#SBATCH -p icelake +#! How many whole nodes should be allocated? +#SBATCH --nodes=1 +#! How many (MPI) tasks will there be in total? (<= nodes*76) +#! The Ice Lake (icelake) nodes have 76 CPUs (cores) each and +#! 3380 MiB of memory per CPU. +#SBATCH --ntasks=32 +#! How much wallclock time will be required? +#SBATCH --time=00:05:00 +#! What types of email messages do you wish to receive? +#SBATCH --mail-type=NONE +#! Uncomment this to prevent the job from being requeued (e.g. if +#! interrupted by node failure or system downtime): +##SBATCH --no-requeue +#! Quality of service i.e. 'QoS' (uncomment for short tests) +#SBATCH --qos=INTR + +#! sbatch directives end here (put any additional directives above this line) + +#! Notes: +#! Charging is determined by cpu number*walltime. +#! The --ntasks value refers to the number of tasks to be launched by SLURM only. This +#! usually equates to the number of MPI tasks launched. Reduce this from nodes*76 if +#! demanded by memory requirements, or if OMP_NUM_THREADS>1. +#! Each task is allocated 1 CPU by default, and each CPU is allocated 3380 MiB +#! of memory. If this is insufficient, also specify +#! --cpus-per-task and/or --mem (the latter specifies MiB per node). + +#! Number of nodes and tasks per node allocated by SLURM (do not change): +numnodes=$SLURM_JOB_NUM_NODES +numtasks=$SLURM_NTASKS +mpi_tasks_per_node=$(echo "$SLURM_TASKS_PER_NODE" | sed -e 's/^\([0-9][0-9]*\).*$/\1/') +#! ############################################################ +#! Modify the settings below to specify the application's environment, location +#! and launch method: + +#! Optionally modify the environment seen by the application +#! (note that SLURM reproduces the environment at submission irrespective of ~/.bashrc): +. /etc/profile.d/modules.sh # Leave this line (enables the module command) +module purge # Removes all modules still loaded +module load rhel8/default-icl # REQUIRED - loads the basic environment + +#! Insert additional module load commands after this line if needed: +module load netcdf-c/4.8.1/intel/intel-oneapi-mpi/sbasfxmz +module load netcdf-fortran/4.5.4/intel/intel-oneapi-mpi/lpmynf72 + +# Extra module for forpy +module load python/3.11.0-icl + +#! Full path to application executable: +application="/home/sjc306/hpc-work/Datawave/MiMA/build-rel-fp/mima.x" + +#! Run options for the application: +options="" + +#! Work directory (i.e. where the job will run): +savedir="/home/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_fp_tf/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory +workdir="/local/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_fp_tf/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory + # in which sbatch is run. + +#! Are you using OpenMP (NB this is unrelated to OpenMPI)? If so increase this +#! safe value to no more than 76: +export OMP_NUM_THREADS=1 + +#! Number of MPI tasks to be started by the application per node and in total (do not change): +np=$[${numnodes}*${mpi_tasks_per_node}] + +#! The following variables define a sensible pinning strategy for Intel MPI tasks - +#! this should be suitable for both pure MPI and hybrid MPI/OpenMP jobs: +export I_MPI_PIN_DOMAIN=omp:compact # Domains are $OMP_NUM_THREADS cores in size +export I_MPI_PIN_ORDER=scatter # Adjacent domains have minimal sharing of caches/sockets +#! Notes: +#! 1. These variables influence Intel MPI only. +#! 2. Domains are non-overlapping sets of cores which map 1-1 to MPI tasks. +#! 3. I_MPI_PIN_PROCESSOR_LIST is ignored if I_MPI_PIN_DOMAIN is set. +#! 4. If MPI tasks perform better when sharing caches/sockets, try I_MPI_PIN_ORDER=compact. + + +#! Uncomment one choice for CMD below (add mpirun/mpiexec options if necessary): + +#! Choose this for a MPI code (possibly using OpenMP) using Intel MPI. +#CMD="mpirun -ppn $mpi_tasks_per_node -np $np $application $options" + +#! Choose this for a pure shared-memory OpenMP parallel program on a single node: +#! (OMP_NUM_THREADS threads will be created): +# CMD="$application $options" +CMD="mpiexec -n $np $application $options" + +#! Choose this for a MPI code (possibly using OpenMP) using OpenMPI: +# CMD="mpirun -npernode $mpi_tasks_per_node -np $np $application $options" + +# Python environment to load +PYENV_TO_LOAD="/home/sjc306/hpc-work/Datawave/MiMA/src/shared/tensorflow/venv" + +# Set hdf5 version check disable? Argh. +export HDF5_DISABLE_VERSION_CHECK=1 + +############################################################### +### You should not have to change anything below this line #### +############################################################### + +mkdir -p $workdir +rm -r $workdir/* +cd $workdir +echo -e "Changed directory to `pwd`.\n" + +echo "Copying /input from ~/MiMA" +cp -r /home/sjc306/hpc-work/Datawave/MiMA/input/* . +echo "Copying input_fp_tf.nml into workdir" +cp /home/sjc306/hpc-work/Datawave/MiMA/input_fp_tf.nml ./input.nml +echo "copying executable" +cp $application . + +echo "Making RESTART directory" +mkdir -p RESTART + +echo "Loading python environment from $PYENV_TO_LOAD" +source $PYENV_TO_LOAD/bin/activate + +echo "Adding to PYTHONPATH" +export PYTHONPATH=/home/sjc306/hpc-work/Datawave/MiMA/src/shared/tensorflow +echo "PYTHONPATH now $PYTHONPATH" + +echo "numnodes=" +echo $SLURM_JOB_NUM_NODES +echo "numtasks=" +echo $SLURM_NTASKS +echo "mpi_tasks_per_node=:" +echo $mpi_tasks_per_node + +JOBID=$SLURM_JOB_ID + +echo -e "JobID: $JOBID\n======" +echo "Time: `date`" +echo "Running on master node: `hostname`" +echo "Current directory: `pwd`" + +if [ "$SLURM_JOB_NODELIST" ]; then + #! Create a machine file: + export NODEFILE=`generate_pbs_nodefile` + cat $NODEFILE | uniq > machine.file.$JOBID + echo -e "\nNodes allocated:\n================" + echo `cat machine.file.$JOBID | sed -e 's/\..*$//g'` +fi + +echo -e "\nnumtasks=$numtasks, numnodes=$numnodes, mpi_tasks_per_node=$mpi_tasks_per_node (OMP_NUM_THREADS=$OMP_NUM_THREADS)" + +echo -e "\nExecuting command:\n==================\n$CMD\n" + +eval $CMD + +echo 'Copying data back' +cp -pr $workdir/* $savedir/ diff --git a/submit_rel_PT.icelake b/submit_rel_PT.icelake new file mode 100755 index 0000000..1beef54 --- /dev/null +++ b/submit_rel_PT.icelake @@ -0,0 +1,156 @@ +#!/bin/bash +#! +#! Example SLURM job script for Peta4-IceLake (Ice Lake CPUs, HDR200 IB) +#! Last updated: Sat Jul 31 15:39:45 BST 2021 +#! + +#!############################################################# +#!#### Modify the options in this section as appropriate ###### +#!############################################################# + +#! sbatch directives begin here ############################### +#! Name of the job: +#SBATCH -J MiMA +#! Which project should be charged: +#SBATCH -A ICCS-SL3-CPU +#SBATCH -p icelake +#! How many whole nodes should be allocated? +#SBATCH --nodes=1 +#! How many (MPI) tasks will there be in total? (<= nodes*76) +#! The Ice Lake (icelake) nodes have 76 CPUs (cores) each and +#! 3380 MiB of memory per CPU. +#SBATCH --ntasks=32 +#! How much wallclock time will be required? +#SBATCH --time=00:05:00 +#! What types of email messages do you wish to receive? +#SBATCH --mail-type=NONE +#! Uncomment this to prevent the job from being requeued (e.g. if +#! interrupted by node failure or system downtime): +##SBATCH --no-requeue +#! Quality of service i.e. 'QoS' (uncomment for short tests) +#SBATCH --qos=INTR + +#! sbatch directives end here (put any additional directives above this line) + +#! Notes: +#! Charging is determined by cpu number*walltime. +#! The --ntasks value refers to the number of tasks to be launched by SLURM only. This +#! usually equates to the number of MPI tasks launched. Reduce this from nodes*76 if +#! demanded by memory requirements, or if OMP_NUM_THREADS>1. +#! Each task is allocated 1 CPU by default, and each CPU is allocated 3380 MiB +#! of memory. If this is insufficient, also specify +#! --cpus-per-task and/or --mem (the latter specifies MiB per node). + +#! Number of nodes and tasks per node allocated by SLURM (do not change): +numnodes=$SLURM_JOB_NUM_NODES +numtasks=$SLURM_NTASKS +mpi_tasks_per_node=$(echo "$SLURM_TASKS_PER_NODE" | sed -e 's/^\([0-9][0-9]*\).*$/\1/') +#! ############################################################ +#! Modify the settings below to specify the application's environment, location +#! and launch method: + +#! Optionally modify the environment seen by the application +#! (note that SLURM reproduces the environment at submission irrespective of ~/.bashrc): +. /etc/profile.d/modules.sh # Leave this line (enables the module command) +module purge # Removes all modules still loaded +module load rhel8/default-icl # REQUIRED - loads the basic environment + +#! Insert additional module load commands after this line if needed: +module load netcdf-c/4.8.1/intel/intel-oneapi-mpi/sbasfxmz +module load netcdf-fortran/4.5.4/intel/intel-oneapi-mpi/lpmynf72 + +#! Full path to application executable: +application="/home/sjc306/hpc-work/Datawave/MiMA/build-rel-pt/mima.x" + +#! Run options for the application: +options="" + +#! Work directory (i.e. where the job will run): +savedir="/home/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_pt/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory +workdir="/local/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_pt/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory + # in which sbatch is run. + +#! Are you using OpenMP (NB this is unrelated to OpenMPI)? If so increase this +#! safe value to no more than 76: +export OMP_NUM_THREADS=1 + +#! Number of MPI tasks to be started by the application per node and in total (do not change): +np=$[${numnodes}*${mpi_tasks_per_node}] + +#! The following variables define a sensible pinning strategy for Intel MPI tasks - +#! this should be suitable for both pure MPI and hybrid MPI/OpenMP jobs: +export I_MPI_PIN_DOMAIN=omp:compact # Domains are $OMP_NUM_THREADS cores in size +export I_MPI_PIN_ORDER=scatter # Adjacent domains have minimal sharing of caches/sockets +#! Notes: +#! 1. These variables influence Intel MPI only. +#! 2. Domains are non-overlapping sets of cores which map 1-1 to MPI tasks. +#! 3. I_MPI_PIN_PROCESSOR_LIST is ignored if I_MPI_PIN_DOMAIN is set. +#! 4. If MPI tasks perform better when sharing caches/sockets, try I_MPI_PIN_ORDER=compact. + + +#! Uncomment one choice for CMD below (add mpirun/mpiexec options if necessary): + +#! Choose this for a MPI code (possibly using OpenMP) using Intel MPI. +#CMD="mpirun -ppn $mpi_tasks_per_node -np $np $application $options" + +#! Choose this for a pure shared-memory OpenMP parallel program on a single node: +#! (OMP_NUM_THREADS threads will be created): +# CMD="$application $options" +CMD="mpiexec -n $np $application $options" + +#! Choose this for a MPI code (possibly using OpenMP) using OpenMPI: +# CMD="mpirun -npernode $mpi_tasks_per_node -np $np $application $options" + + +############################################################### +### You should not have to change anything below this line #### +############################################################### + +mkdir -p $workdir +rm -r $workdir/* +cd $workdir +echo -e "Changed directory to `pwd`.\n" + +echo "Copying /input from ~/MiMA" +cp -r /home/sjc306/hpc-work/Datawave/MiMA/input/* . +echo "Copying input_pt.nml into workdir" +cp /home/sjc306/hpc-work/Datawave/MiMA/input_pt.nml ./input.nml +echo "copying executable" +cp $application . + +echo "Making RESTART directory" +mkdir -p RESTART + +echo "Copying network_wst.pkl" +cp /home/sjc306/hpc-work/Datawave/MiMA/src/shared/pytorch/network_wst.pkl . + +echo "numnodes=" +echo $SLURM_JOB_NUM_NODES +echo "numtasks=" +echo $SLURM_NTASKS +echo "mpi_tasks_per_node=:" +echo $mpi_tasks_per_node + +JOBID=$SLURM_JOB_ID + +echo -e "JobID: $JOBID\n======" +echo "Time: `date`" +echo "Running on master node: `hostname`" +echo "Current directory: `pwd`" + +if [ "$SLURM_JOB_NODELIST" ]; then + #! Create a machine file: + export NODEFILE=`generate_pbs_nodefile` + cat $NODEFILE | uniq > machine.file.$JOBID + echo -e "\nNodes allocated:\n================" + echo `cat machine.file.$JOBID | sed -e 's/\..*$//g'` +fi + +echo -e "\nnumtasks=$numtasks, numnodes=$numnodes, mpi_tasks_per_node=$mpi_tasks_per_node (OMP_NUM_THREADS=$OMP_NUM_THREADS)" + +echo -e "\nExecuting command:\n==================\n$CMD\n" + +eval $CMD + +echo 'Copying data back' +cp -pr $workdir/* $savedir/ diff --git a/submit_rel_TF.icelake b/submit_rel_TF.icelake new file mode 100755 index 0000000..1233783 --- /dev/null +++ b/submit_rel_TF.icelake @@ -0,0 +1,153 @@ +#!/bin/bash +#! +#! Example SLURM job script for Peta4-IceLake (Ice Lake CPUs, HDR200 IB) +#! Last updated: Sat Jul 31 15:39:45 BST 2021 +#! + +#!############################################################# +#!#### Modify the options in this section as appropriate ###### +#!############################################################# + +#! sbatch directives begin here ############################### +#! Name of the job: +#SBATCH -J MiMA +#! Which project should be charged: +#SBATCH -A ICCS-SL3-CPU +#SBATCH -p icelake +#! How many whole nodes should be allocated? +#SBATCH --nodes=1 +#! How many (MPI) tasks will there be in total? (<= nodes*76) +#! The Ice Lake (icelake) nodes have 76 CPUs (cores) each and +#! 3380 MiB of memory per CPU. +#SBATCH --ntasks=32 +#! How much wallclock time will be required? +#SBATCH --time=00:05:00 +#! What types of email messages do you wish to receive? +#SBATCH --mail-type=NONE +#! Uncomment this to prevent the job from being requeued (e.g. if +#! interrupted by node failure or system downtime): +##SBATCH --no-requeue +#! Quality of service i.e. 'QoS' (uncomment for short tests) +#SBATCH --qos=INTR + +#! sbatch directives end here (put any additional directives above this line) + +#! Notes: +#! Charging is determined by cpu number*walltime. +#! The --ntasks value refers to the number of tasks to be launched by SLURM only. This +#! usually equates to the number of MPI tasks launched. Reduce this from nodes*76 if +#! demanded by memory requirements, or if OMP_NUM_THREADS>1. +#! Each task is allocated 1 CPU by default, and each CPU is allocated 3380 MiB +#! of memory. If this is insufficient, also specify +#! --cpus-per-task and/or --mem (the latter specifies MiB per node). + +#! Number of nodes and tasks per node allocated by SLURM (do not change): +numnodes=$SLURM_JOB_NUM_NODES +numtasks=$SLURM_NTASKS +mpi_tasks_per_node=$(echo "$SLURM_TASKS_PER_NODE" | sed -e 's/^\([0-9][0-9]*\).*$/\1/') +#! ############################################################ +#! Modify the settings below to specify the application's environment, location +#! and launch method: + +#! Optionally modify the environment seen by the application +#! (note that SLURM reproduces the environment at submission irrespective of ~/.bashrc): +. /etc/profile.d/modules.sh # Leave this line (enables the module command) +module purge # Removes all modules still loaded +module load rhel8/default-icl # REQUIRED - loads the basic environment + +#! Insert additional module load commands after this line if needed: +module load netcdf-c/4.8.1/intel/intel-oneapi-mpi/sbasfxmz +module load netcdf-fortran/4.5.4/intel/intel-oneapi-mpi/lpmynf72 + +#! Full path to application executable: +application="/home/sjc306/hpc-work/Datawave/MiMA/build-rel-tf/mima.x" + +#! Run options for the application: +options="" + +#! Work directory (i.e. where the job will run): +savedir="/home/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_tf/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory +workdir="/local/sjc306/hpc-work/Datawave/MiMA/MiMA_datawave_tf/" # The value of SLURM_SUBMIT_DIR sets workdir to the directory + # in which sbatch is run. + +#! Are you using OpenMP (NB this is unrelated to OpenMPI)? If so increase this +#! safe value to no more than 76: +export OMP_NUM_THREADS=1 + +#! Number of MPI tasks to be started by the application per node and in total (do not change): +np=$[${numnodes}*${mpi_tasks_per_node}] + +#! The following variables define a sensible pinning strategy for Intel MPI tasks - +#! this should be suitable for both pure MPI and hybrid MPI/OpenMP jobs: +export I_MPI_PIN_DOMAIN=omp:compact # Domains are $OMP_NUM_THREADS cores in size +export I_MPI_PIN_ORDER=scatter # Adjacent domains have minimal sharing of caches/sockets +#! Notes: +#! 1. These variables influence Intel MPI only. +#! 2. Domains are non-overlapping sets of cores which map 1-1 to MPI tasks. +#! 3. I_MPI_PIN_PROCESSOR_LIST is ignored if I_MPI_PIN_DOMAIN is set. +#! 4. If MPI tasks perform better when sharing caches/sockets, try I_MPI_PIN_ORDER=compact. + + +#! Uncomment one choice for CMD below (add mpirun/mpiexec options if necessary): + +#! Choose this for a MPI code (possibly using OpenMP) using Intel MPI. +#CMD="mpirun -ppn $mpi_tasks_per_node -np $np $application $options" + +#! Choose this for a pure shared-memory OpenMP parallel program on a single node: +#! (OMP_NUM_THREADS threads will be created): +# CMD="$application $options" +CMD="mpiexec -n $np $application $options" + +#! Choose this for a MPI code (possibly using OpenMP) using OpenMPI: +# CMD="mpirun -npernode $mpi_tasks_per_node -np $np $application $options" + + +############################################################### +### You should not have to change anything below this line #### +############################################################### + +mkdir -p $workdir +rm -r $workdir/* +cd $workdir +echo -e "Changed directory to `pwd`.\n" + +echo "Copying /input from ~/MiMA" +cp -r /home/sjc306/hpc-work/Datawave/MiMA/input/* . +echo "Copying input_tf.nml into workdir" +cp /home/sjc306/hpc-work/Datawave/MiMA/input_tf.nml ./input.nml +echo "copying executable" +cp $application . + +echo "Making RESTART directory" +mkdir -p RESTART + +echo "numnodes=" +echo $SLURM_JOB_NUM_NODES +echo "numtasks=" +echo $SLURM_NTASKS +echo "mpi_tasks_per_node=:" +echo $mpi_tasks_per_node + +JOBID=$SLURM_JOB_ID + +echo -e "JobID: $JOBID\n======" +echo "Time: `date`" +echo "Running on master node: `hostname`" +echo "Current directory: `pwd`" + +if [ "$SLURM_JOB_NODELIST" ]; then + #! Create a machine file: + export NODEFILE=`generate_pbs_nodefile` + cat $NODEFILE | uniq > machine.file.$JOBID + echo -e "\nNodes allocated:\n================" + echo `cat machine.file.$JOBID | sed -e 's/\..*$//g'` +fi + +echo -e "\nnumtasks=$numtasks, numnodes=$numnodes, mpi_tasks_per_node=$mpi_tasks_per_node (OMP_NUM_THREADS=$OMP_NUM_THREADS)" + +echo -e "\nExecuting command:\n==================\n$CMD\n" + +eval $CMD + +echo 'Copying data back' +cp -pr $workdir/* $savedir/