From 753e2d2e42646cbf6be5bf81213cf855a6d886bd Mon Sep 17 00:00:00 2001 From: Balthasar Reuter Date: Thu, 21 Mar 2024 11:40:52 +0100 Subject: [PATCH 1/5] Loki IDEM and SCC working with NEW scheduler, STACK variants not (yet) --- src/ecwam/CMakeLists.txt | 195 +++++++++++++++++++------------- src/ecwam/ecwam_loki.config | 60 ++++++---- src/ecwam/ecwam_loki_gpu.config | 70 +++++++----- src/programs/CMakeLists.txt | 18 +-- 4 files changed, 210 insertions(+), 133 deletions(-) diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 69cac7473..9c43851f3 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -477,14 +477,27 @@ if( HAVE_WAM_LOKI ) list(APPEND loki_idem_srcs ${fnm}) endforeach() - loki_transform_convert( - MODE idem FRONTEND ${LOKI_FRONTEND} CPP - CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config - PATH ${CMAKE_CURRENT_SOURCE_DIR} - INCLUDES ${ecwam_intfb_includes} - OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-idem - OUTPUT ${loki_idem_srcs} - DEPENDS ${phys_srcs} + # loki_transform_convert( + # MODE idem FRONTEND ${LOKI_FRONTEND} CPP + # CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config + # PATH ${CMAKE_CURRENT_SOURCE_DIR} + # INCLUDES ${ecwam_intfb_includes} + # OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-idem + # OUTPUT ${loki_idem_srcs} + # DEPENDS ${phys_srcs} + # ) + + loki_transform( + COMMAND convert + OUTPUT ${loki_idem_srcs} + BUILDDIR ${CMAKE_CURRENT_BINARY_DIR}/loki-idem + DEPENDS ${phys_srcs} + MODE idem + CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config + CPP + FRONTEND ${LOKI_FRONTEND} + SOURCES ${CMAKE_CURRENT_SOURCE_DIR} + INCLUDES ${ecwam_intfb_includes} ) ecbuild_add_library( @@ -517,19 +530,32 @@ if( HAVE_WAM_LOKI ) ## * Internal "do-nothing" mode for Loki debug ## ############################################################ foreach(src ${phys_srcs} wamintgr.F90) - string(REPLACE ".F90" "" fnc ${src}) - string(CONCAT fnm "loki-idem-stack/" ${fnc} ".idem_stack.F90") - list(APPEND loki_idem_stack_srcs ${fnm}) - endforeach() - - loki_transform_convert( - MODE idem-stack FRONTEND ${LOKI_FRONTEND} CPP - CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config - PATH ${CMAKE_CURRENT_SOURCE_DIR} - INCLUDES ${ecwam_intfb_includes} - OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-idem-stack - OUTPUT ${loki_idem_stack_srcs} - DEPENDS ${phys_srcs} + string(REPLACE ".F90" "" fnc ${src}) + string(CONCAT fnm "loki-idem-stack/" ${fnc} ".idem_stack.F90") + list(APPEND loki_idem_stack_srcs ${fnm}) + endforeach() + + # loki_transform_convert( + # MODE idem-stack FRONTEND ${LOKI_FRONTEND} CPP + # CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config + # PATH ${CMAKE_CURRENT_SOURCE_DIR} + # INCLUDES ${ecwam_intfb_includes} + # OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-idem-stack + # OUTPUT ${loki_idem_stack_srcs} + # DEPENDS ${phys_srcs} + # ) + + loki_transform( + COMMAND convert + OUTPUT ${loki_idem_stack_srcs} + BUILDDIR ${CMAKE_CURRENT_BINARY_DIR}/loki-idem-stack + DEPENDS ${phys_srcs} + MODE idem-stack + CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config + CPP + FRONTEND ${LOKI_FRONTEND} + SOURCES ${CMAKE_CURRENT_SOURCE_DIR} + INCLUDES ${ecwam_intfb_includes} ) ecbuild_add_library( @@ -554,9 +580,9 @@ if( HAVE_WAM_LOKI ) MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/${ecwam}_idem_stack INSTALL_DIRECTORY module/${ecwam}_idem_stack ) - + ecwam_target_compile_definitions_FILENAME( ${ecwam}_idem_stack ) - + if( CMAKE_Fortran_COMPILER_ID MATCHES PGI|NVHPC ) target_compile_options( ${ecwam}_idem_stack PUBLIC "-Mcray=pointer" ) elseif( CMAKE_Fortran_COMPILER_ID MATCHES GNU ) @@ -573,14 +599,27 @@ if( HAVE_WAM_LOKI ) list(APPEND loki_scc_srcs ${fnm}) endforeach() - loki_transform_convert( - MODE scc FRONTEND ${LOKI_FRONTEND} CPP GLOBAL_VAR_OFFLOAD TRIM_VECTOR_SECTIONS - CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki_gpu.config - PATH ${CMAKE_CURRENT_SOURCE_DIR} - INCLUDES ${ecwam_intfb_includes} - OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-scc - OUTPUT ${loki_scc_srcs} - DEPENDS ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods} + # loki_transform_convert( + # MODE scc FRONTEND ${LOKI_FRONTEND} CPP GLOBAL_VAR_OFFLOAD TRIM_VECTOR_SECTIONS + # CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki_gpu.config + # PATH ${CMAKE_CURRENT_SOURCE_DIR} + # INCLUDES ${ecwam_intfb_includes} + #  OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-scc + # OUTPUT ${loki_scc_srcs} + # DEPENDS ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods} + # ) + + loki_transform( + COMMAND convert + OUTPUT ${loki_scc_srcs} + BUILDDIR ${CMAKE_CURRENT_BINARY_DIR}/loki-scc + DEPENDS ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods} + MODE scc + CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki_gpu.config + CPP GLOBAL_VAR_OFFLOAD TRIM_VECTOR_SECTIONS + FRONTEND ${LOKI_FRONTEND} + SOURCES ${CMAKE_CURRENT_SOURCE_DIR} + INCLUDES ${ecwam_intfb_includes} ) ecbuild_add_library( @@ -616,56 +655,56 @@ if( HAVE_WAM_LOKI ) ############################################################ ## Loki SCC with pool allocator for temporaries: ## ############################################################ - foreach(src ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods}) - string(REPLACE ".F90" "" fnc ${src}) - string(CONCAT fnm "loki-scc-stack/" ${fnc} ".scc_stack.F90") - list(APPEND loki_scc_stack_srcs ${fnm}) - endforeach() - - loki_transform_convert( - MODE scc-stack FRONTEND ${LOKI_FRONTEND} CPP GLOBAL_VAR_OFFLOAD TRIM_VECTOR_SECTIONS - CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki_gpu.config - PATH ${CMAKE_CURRENT_SOURCE_DIR} - INCLUDES ${ecwam_intfb_includes} - OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-scc-stack - OUTPUT ${loki_scc_stack_srcs} - DEPENDS ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods} - ) - - ecbuild_add_library( - TARGET ${ecwam}_scc_stack - TYPE ${LIBRARY_TYPE} - DEFINITIONS ${ECWAM_DEFINITIONS} WAM_PHYS_GPU - SOURCES ${ecwam_srcs} ${loki_scc_stack_srcs} ${phys_srcs} - PUBLIC_LIBS fiat parkind_${prec} ${ecwam}_intfb - ${MPI_Fortran_LIBRARIES} - ${${PNAME}_OCEANMODEL_LIBRARIES} - $<${HAVE_ACC}:OpenACC::OpenACC_Fortran> - PRIVATE_LIBS eccodes_f90 - ${MULTIO_LIBRARIES} - ${OpenMP_Fortran_LIBRARIES} - $<${HAVE_FIELD_API}:field_api_${prec}> - MPI::MPI_Fortran - PUBLIC_INCLUDES $ - PRIVATE_INCLUDES ${${PNAME}_OCEANMODEL_INCLUDE_DIRS} ${CMAKE_CURRENT_SOURCE_DIR} - ) + #foreach(src ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods}) + # string(REPLACE ".F90" "" fnc ${src}) + # string(CONCAT fnm "loki-scc-stack/" ${fnc} ".scc_stack.F90") + # list(APPEND loki_scc_stack_srcs ${fnm}) + #endforeach() + + #loki_transform_convert( + # MODE scc-stack FRONTEND ${LOKI_FRONTEND} CPP GLOBAL_VAR_OFFLOAD TRIM_VECTOR_SECTIONS + # CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki_gpu.config + # PATH ${CMAKE_CURRENT_SOURCE_DIR} + # INCLUDES ${ecwam_intfb_includes} + # OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-scc-stack + # OUTPUT ${loki_scc_stack_srcs} + # DEPENDS ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods} + #) + + #ecbuild_add_library( + # TARGET ${ecwam}_scc_stack + # TYPE ${LIBRARY_TYPE} + # DEFINITIONS ${ECWAM_DEFINITIONS} WAM_PHYS_GPU + # SOURCES ${ecwam_srcs} ${loki_scc_stack_srcs} ${phys_srcs} + # PUBLIC_LIBS fiat parkind_${prec} ${ecwam}_intfb + # ${MPI_Fortran_LIBRARIES} + # ${${PNAME}_OCEANMODEL_LIBRARIES} + # $<${HAVE_ACC}:OpenACC::OpenACC_Fortran> + # PRIVATE_LIBS eccodes_f90 + # ${MULTIO_LIBRARIES} + # ${OpenMP_Fortran_LIBRARIES} + # $<${HAVE_FIELD_API}:field_api_${prec}> + # MPI::MPI_Fortran + # PUBLIC_INCLUDES $ + # PRIVATE_INCLUDES ${${PNAME}_OCEANMODEL_INCLUDE_DIRS} ${CMAKE_CURRENT_SOURCE_DIR} + #) - ecwam_target_fortran_module_directory( - TARGET ${ecwam}_scc_stack - MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/${ecwam}_scc_stack - INSTALL_DIRECTORY module/${ecwam}_scc_stack - ) + #ecwam_target_fortran_module_directory( + # TARGET ${ecwam}_scc_stack + # MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/${ecwam}_scc_stack + # INSTALL_DIRECTORY module/${ecwam}_scc_stack + #) - ecwam_target_compile_definitions_FILENAME( ${ecwam}_scc_stack ) + #ecwam_target_compile_definitions_FILENAME( ${ecwam}_scc_stack ) - if( CMAKE_Fortran_COMPILER_ID MATCHES PGI|NVHPC ) - target_compile_options( ${ecwam}_scc_stack PUBLIC "-Mcray=pointer" ) - if( HAVE_ACC ) - target_compile_options( ${ecwam}_scc_stack PUBLIC "-gpu=gvmode,maxregcount:128" ) - endif() - elseif( CMAKE_Fortran_COMPILER_ID MATCHES GNU ) - target_compile_options( ${ecwam}_scc_stack PUBLIC "-fcray-pointer" ) - endif() + #if( CMAKE_Fortran_COMPILER_ID MATCHES PGI|NVHPC ) + # target_compile_options( ${ecwam}_scc_stack PUBLIC "-Mcray=pointer" ) + # if( HAVE_ACC ) + # target_compile_options( ${ecwam}_scc_stack PUBLIC "-gpu=gvmode,maxregcount:128" ) + # endif() + #elseif( CMAKE_Fortran_COMPILER_ID MATCHES GNU ) + # target_compile_options( ${ecwam}_scc_stack PUBLIC "-fcray-pointer" ) + #endif() endif() endif() diff --git a/src/ecwam/ecwam_loki.config b/src/ecwam/ecwam_loki.config index fd95a55b2..e88542a56 100644 --- a/src/ecwam/ecwam_loki.config +++ b/src/ecwam/ecwam_loki.config @@ -3,35 +3,55 @@ mode = "idem" role = "kernel" expand = true strict = true -disable = [ - "DR_HOOK", "lhook", "jphook", "omp_get_wtime", "flush", "jwim", - "jwrb", "jwru", "jwro", "environment", "frequency", - "forcing_fields", "intgt_param_fields", "wave2ocean", "abort1", - "iu06" -] +# Ensure that we are never adding these to the tree, and thus +# do not attempt to look up the source files for these. +#disable = [ +# "DR_HOOK", "lhook", "jphook", "omp_get_wtime", "flush", "jwim", +# "jwrb", "jwru", "jwro", "environment", "frequency", +# "forcing_fields", "intgt_param_fields", "wave2ocean", "abort1", +# "iu06" +#] +# , 'dr_hook', 'lhook', 'jphook', ' + +disable = ['yomhook', 'abort', 'wave2ocean', 'intgt_param_fields', + 'forcing_fields', 'environment', 'yomgstats', 'gstats', 'gstats_barrier', 'frequency_field', + 'environment_field', 'source_contribs_field', 'intgt_param_fields', + 'source_contribs_field', 'system_clock', 'ec_parkind', 'parkind_wave', 'parkind1', + 'wam_multio_mod', 'flush', 'yowabort', 'mpl_module', 'yowtest', 'oml_mod', + 'ieee_arithmetic', 'outwspec_io_serv_handler', 'outint_io_serv_handler', + 'ifstowam_handler', 'mfeb_length', 'mon', 'isamesign', 'cdm', 'abor1', 'abort1', 'abort1_mod', + 'yowfield_mod', 'ctuw_mod', 'wam_user_clock', + 'propag_wam', 'newwind', 'incdate'] + +# Prune the tree for these to ensure they are not processed by transformations +block = ['ec_parkind', 'parkind_wave', 'parkind1', 'mfeb_length', 'mon', 'isamesign'] # , 'yoecldp', 'fc*_mod'] + utility_routines = ['dr_hook', 'abort1', 'write(iu06'] enable_imports = false # Define entry point for call-tree transformation [routines] +# [routines.meansqs_gc] +# disable = ['omegagc'] + [routines.wamintgr] role = "driver" expand = true - disable = [ - "PROPAG_WAM", "NEWWIND", "GSTATS", "FREQUENCY_FIELD%INIT", - "ENVIRONMENT_FIELD%INIT", "FORCING_FIELDS_FIELD%INIT", - "WAVE2OCEAN_FIELD%INIT", "INTGT_PARAM_FIELDS_FIELD%INIT", - "FREQUENCY_FIELD%UPDATE_VIEW", "ENVIRONMENT_FIELD%UPDATE_VIEW", - "FORCING_FIELDS_FIELD%UPDATE_VIEW", "WAVE2OCEAN_FIELD%UPDATE_VIEW", - "INTGT_PARAM_FIELDS_FIELD%UPDATE_VIEW", - "SOURCE_CONTRIBS_FIELD%INIT", "SOURCE_CONTRIBS_FIELD%UPDATE_VIEW", - "INCDATE", "DR_HOOK", "omp_get_wtime", "abort1", "wam_user_clock", - "FREQUENCY_FIELD%FINAL", "ENVIRONMENT_FIELD%FINAL", - "FORCING_FIELDS_FIELD%FINAL", "WAVE2OCEAN_FIELD%FINAL", - "INTGT_PARAM_FIELDS_FIELD%FINAL", "SOURCE_CONTRIBS_FIELD%INIT", - "SOURCE_CONTRIBS_FIELD%FINAL" - ] + # disable = [ + # "PROPAG_WAM", "NEWWIND", "GSTATS", "FREQUENCY_FIELD%INIT", + # "ENVIRONMENT_FIELD%INIT", "FORCING_FIELDS_FIELD%INIT", + # "WAVE2OCEAN_FIELD%INIT", "INTGT_PARAM_FIELDS_FIELD%INIT", + # "FREQUENCY_FIELD%UPDATE_VIEW", "ENVIRONMENT_FIELD%UPDATE_VIEW", + # "FORCING_FIELDS_FIELD%UPDATE_VIEW", "WAVE2OCEAN_FIELD%UPDATE_VIEW", + # "INTGT_PARAM_FIELDS_FIELD%UPDATE_VIEW", + # "SOURCE_CONTRIBS_FIELD%INIT", "SOURCE_CONTRIBS_FIELD%UPDATE_VIEW", + # "INCDATE", "DR_HOOK", "omp_get_wtime", "abort1", "wam_user_clock", + # "FREQUENCY_FIELD%FINAL", "ENVIRONMENT_FIELD%FINAL", + # "FORCING_FIELDS_FIELD%FINAL", "WAVE2OCEAN_FIELD%FINAL", + # "INTGT_PARAM_FIELDS_FIELD%FINAL", "SOURCE_CONTRIBS_FIELD%INIT", + #  "SOURCE_CONTRIBS_FIELD%FINAL" + # ] real_kind = 'JWRB' # Define indices and bounds for array dimensions diff --git a/src/ecwam/ecwam_loki_gpu.config b/src/ecwam/ecwam_loki_gpu.config index 302bf9685..5dc4ff6af 100644 --- a/src/ecwam/ecwam_loki_gpu.config +++ b/src/ecwam/ecwam_loki_gpu.config @@ -3,41 +3,59 @@ mode = "idem" role = "kernel" expand = true strict = true -disable = [ - "DR_HOOK", "lhook", "jphook", "omp_get_wtime", "flush", "jwim", - "jwrb", "jwru", "jwro", "environment", "frequency", - "forcing_fields", "intgt_param_fields", "wave2ocean", "abort1", - "iu06" -] +#disable = [ +# "DR_HOOK", "lhook", "jphook", "omp_get_wtime", "flush", "jwim", +# "jwrb", "jwru", "jwro", "environment", "frequency", +# "forcing_fields", "intgt_param_fields", "wave2ocean", "abort1", +# "iu06" +#] + +# , 'dr_hook', 'lhook', 'jphook', ' +disable = ['yomhook', 'abort', 'wave2ocean', 'intgt_param_fields', + 'forcing_fields', 'environment', 'yomgstats', 'gstats', 'gstats_barrier', 'frequency_field', + 'environment_field', 'source_contribs_field', 'intgt_param_fields', + 'source_contribs_field', 'system_clock', 'ec_parkind', 'parkind_wave', 'parkind1', + 'wam_multio_mod', 'flush', 'yowabort', 'mpl_module', 'yowtest', 'oml_mod', + 'ieee_arithmetic', 'outwspec_io_serv_handler', 'outint_io_serv_handler', + 'ifstowam_handler', 'mfeb_length', 'mon', 'isamesign', 'cdm', 'abor1', 'abort1', 'abort1_mod', + 'yowfield_mod', 'ctuw_mod', 'wam_user_clock', + 'propag_wam', 'newwind', 'incdate'] + +# Prune the tree for these to ensure they are not processed by transformations +block = ['ec_parkind', 'parkind_wave', 'parkind1', 'mfeb_length'] # , 'yoecldp', 'fc*_mod'] + utility_routines = ['dr_hook', 'abort1', 'write(iu06'] enable_imports = true # Define entry point for call-tree transformation [routines] +# [routines.meansqs_gc] +# disable = ['omegagc'] + [routines.wamintgr_loki_gpu] role = "driver" expand = true - disable = [ - "PROPAG_WAM", "NEWWIND", "GSTATS", "FREQUENCY_FIELD%INIT", - "ENVIRONMENT_FIELD%INIT", "FORCING_FIELDS_FIELD%INIT", - "WAVE2OCEAN_FIELD%INIT", "INTGT_PARAM_FIELDS_FIELD%INIT", - "FREQUENCY_FIELD%UPDATE_DEVICE", "ENVIRONMENT_FIELD%UPDATE_DEVICE", - "FORCING_FIELDS_FIELD%UPDATE_DEVICE", - "WAVE2OCEAN_FIELD%UPDATE_DEVICE", - "INTGT_PARAM_FIELDS_FIELD%UPDATE_DEVICE", - "SOURCE_CONTRIBS_FIELD%INIT", "SOURCE_CONTRIBS_FIELD%UPDATE_DEVICE", - "INCDATE", "DR_HOOK", "omp_get_wtime", "abort1", "wam_user_clock", - "FREQUENCY_FIELD%ENSURE_HOST", "ENVIRONMENT_FIELD%ENSURE_HOST", - "FORCING_FIELDS_FIELD%ENSURE_HOST", "WAVE2OCEAN_FIELD%ENSURE_HOST", - "INTGT_PARAM_FIELDS_FIELD%ENSURE_HOST", - "SOURCE_CONTRIBS_FIELD%INIT", "SOURCE_CONTRIBS_FIELD%ENSURE_HOST", - "FREQUENCY_FIELD%FINAL", "ENVIRONMENT_FIELD%FINAL", - "FORCING_FIELDS_FIELD%FINAL", "WAVE2OCEAN_FIELD%FINAL", - "INTGT_PARAM_FIELDS_FIELD%FINAL", "SOURCE_CONTRIBS_FIELD%INIT", - "SOURCE_CONTRIBS_FIELD%FINAL" - ] - enable_imports = false + # disable = [ + # "PROPAG_WAM", "NEWWIND", "GSTATS", "FREQUENCY_FIELD%INIT", + # "ENVIRONMENT_FIELD%INIT", "FORCING_FIELDS_FIELD%INIT", + # "WAVE2OCEAN_FIELD%INIT", "INTGT_PARAM_FIELDS_FIELD%INIT", + # "FREQUENCY_FIELD%UPDATE_DEVICE", "ENVIRONMENT_FIELD%UPDATE_DEVICE", + # "FORCING_FIELDS_FIELD%UPDATE_DEVICE", + # "WAVE2OCEAN_FIELD%UPDATE_DEVICE", + # "INTGT_PARAM_FIELDS_FIELD%UPDATE_DEVICE", + # "SOURCE_CONTRIBS_FIELD%INIT", "SOURCE_CONTRIBS_FIELD%UPDATE_DEVICE", + # "INCDATE", "DR_HOOK", "omp_get_wtime", "abort1", "wam_user_clock", + # "FREQUENCY_FIELD%ENSURE_HOST", "ENVIRONMENT_FIELD%ENSURE_HOST", + # "FORCING_FIELDS_FIELD%ENSURE_HOST", "WAVE2OCEAN_FIELD%ENSURE_HOST", + # "INTGT_PARAM_FIELDS_FIELD%ENSURE_HOST", + # "SOURCE_CONTRIBS_FIELD%INIT", "SOURCE_CONTRIBS_FIELD%ENSURE_HOST", + # "FREQUENCY_FIELD%FINAL", "ENVIRONMENT_FIELD%FINAL", + # "FORCING_FIELDS_FIELD%FINAL", "WAVE2OCEAN_FIELD%FINAL", + # "INTGT_PARAM_FIELDS_FIELD%FINAL", "SOURCE_CONTRIBS_FIELD%INIT", + # "SOURCE_CONTRIBS_FIELD%FINAL" + # ] + # enable_imports = false real_kind = 'JWRB' # Define indices and bounds for array dimensions diff --git a/src/programs/CMakeLists.txt b/src/programs/CMakeLists.txt index 7af5545e9..7e921e4a7 100644 --- a/src/programs/CMakeLists.txt +++ b/src/programs/CMakeLists.txt @@ -32,9 +32,9 @@ if( HAVE_WAM_LOKI ) ecwam_target_compile_definitions_FILENAME(${PROJECT_NAME}-chief-loki-idem) ecbuild_add_executable( - TARGET ${PROJECT_NAME}-chief-loki-idem-stack - SOURCES chief.F90 - LIBS ${PROJECT_NAME}_idem_stack ${OpenMP_Fortran_LIBRARIES} + TARGET ${PROJECT_NAME}-chief-loki-idem-stack + SOURCES chief.F90 + LIBS ${PROJECT_NAME}_idem_stack ${OpenMP_Fortran_LIBRARIES} ) ecwam_target_compile_definitions_FILENAME(${PROJECT_NAME}-chief-loki-idem-stack) @@ -46,12 +46,12 @@ if( HAVE_WAM_LOKI ) ) ecwam_target_compile_definitions_FILENAME(${PROJECT_NAME}-chief-loki-scc) - ecbuild_add_executable( - TARGET ${PROJECT_NAME}-chief-loki-scc-stack - SOURCES chief.F90 - LIBS ${PROJECT_NAME}_scc_stack ${OpenMP_Fortran_LIBRARIES} - ) - ecwam_target_compile_definitions_FILENAME(${PROJECT_NAME}-chief-loki-scc-stack) + # ecbuild_add_executable( + # TARGET ${PROJECT_NAME}-chief-loki-scc-stack + # SOURCES chief.F90 + # LIBS ${PROJECT_NAME}_scc_stack ${OpenMP_Fortran_LIBRARIES} + # ) + # ecwam_target_compile_definitions_FILENAME(${PROJECT_NAME}-chief-loki-scc-stack) endif() endif() From 6df66bcec1729281353892b817dbc9eaa18f2ab3 Mon Sep 17 00:00:00 2001 From: Balthasar Reuter Date: Thu, 21 Mar 2024 11:47:09 +0100 Subject: [PATCH 2/5] Re-enable SCC-Stack for compatibility with new scheduler --- src/ecwam/CMakeLists.txt | 282 ++++++++++++++++-------------------- src/programs/CMakeLists.txt | 12 +- 2 files changed, 133 insertions(+), 161 deletions(-) diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 9c43851f3..3002deef0 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -437,7 +437,7 @@ ecbuild_add_library( ${MULTIO_LIBRARIES} ${OpenMP_Fortran_LIBRARIES} $<${HAVE_FIELD_API}:field_api_${prec}> - MPI::MPI_Fortran + MPI::MPI_Fortran PUBLIC_INCLUDES $ PRIVATE_INCLUDES ${${PNAME}_OCEANMODEL_INCLUDE_DIRS} ) @@ -472,32 +472,22 @@ if( HAVE_WAM_LOKI ) ## * Internal "do-nothing" mode for Loki debug ## ############################################################ foreach(src ${phys_srcs} wamintgr.F90) - string(REPLACE ".F90" "" fnc ${src}) - string(CONCAT fnm "loki-idem/" ${fnc} ".idem.F90") - list(APPEND loki_idem_srcs ${fnm}) + string(REPLACE ".F90" "" fnc ${src}) + string(CONCAT fnm "loki-idem/" ${fnc} ".idem.F90") + list(APPEND loki_idem_srcs ${fnm}) endforeach() - # loki_transform_convert( - # MODE idem FRONTEND ${LOKI_FRONTEND} CPP - # CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config - # PATH ${CMAKE_CURRENT_SOURCE_DIR} - # INCLUDES ${ecwam_intfb_includes} - # OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-idem - # OUTPUT ${loki_idem_srcs} - # DEPENDS ${phys_srcs} - # ) - loki_transform( - COMMAND convert - OUTPUT ${loki_idem_srcs} - BUILDDIR ${CMAKE_CURRENT_BINARY_DIR}/loki-idem - DEPENDS ${phys_srcs} - MODE idem - CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config - CPP - FRONTEND ${LOKI_FRONTEND} - SOURCES ${CMAKE_CURRENT_SOURCE_DIR} - INCLUDES ${ecwam_intfb_includes} + COMMAND convert + OUTPUT ${loki_idem_srcs} + BUILDDIR ${CMAKE_CURRENT_BINARY_DIR}/loki-idem + DEPENDS ${phys_srcs} + MODE idem + CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config + CPP + FRONTEND ${LOKI_FRONTEND} + SOURCES ${CMAKE_CURRENT_SOURCE_DIR} + INCLUDES ${ecwam_intfb_includes} ) ecbuild_add_library( @@ -512,7 +502,7 @@ if( HAVE_WAM_LOKI ) ${MULTIO_LIBRARIES} ${OpenMP_Fortran_LIBRARIES} $<${HAVE_FIELD_API}:field_api_${prec}> - MPI::MPI_Fortran + MPI::MPI_Fortran PUBLIC_INCLUDES $ PRIVATE_INCLUDES ${${PNAME}_OCEANMODEL_INCLUDE_DIRS} ${CMAKE_CURRENT_SOURCE_DIR} ) @@ -533,29 +523,19 @@ if( HAVE_WAM_LOKI ) string(REPLACE ".F90" "" fnc ${src}) string(CONCAT fnm "loki-idem-stack/" ${fnc} ".idem_stack.F90") list(APPEND loki_idem_stack_srcs ${fnm}) - endforeach() - - # loki_transform_convert( - # MODE idem-stack FRONTEND ${LOKI_FRONTEND} CPP - # CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config - # PATH ${CMAKE_CURRENT_SOURCE_DIR} - # INCLUDES ${ecwam_intfb_includes} - # OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-idem-stack - # OUTPUT ${loki_idem_stack_srcs} - # DEPENDS ${phys_srcs} - # ) + endforeach() loki_transform( - COMMAND convert - OUTPUT ${loki_idem_stack_srcs} - BUILDDIR ${CMAKE_CURRENT_BINARY_DIR}/loki-idem-stack - DEPENDS ${phys_srcs} - MODE idem-stack - CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config - CPP - FRONTEND ${LOKI_FRONTEND} - SOURCES ${CMAKE_CURRENT_SOURCE_DIR} - INCLUDES ${ecwam_intfb_includes} + COMMAND convert + OUTPUT ${loki_idem_stack_srcs} + BUILDDIR ${CMAKE_CURRENT_BINARY_DIR}/loki-idem-stack + DEPENDS ${phys_srcs} + MODE idem-stack + CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki.config + CPP + FRONTEND ${LOKI_FRONTEND} + SOURCES ${CMAKE_CURRENT_SOURCE_DIR} + INCLUDES ${ecwam_intfb_includes} ) ecbuild_add_library( @@ -570,7 +550,7 @@ if( HAVE_WAM_LOKI ) ${MULTIO_LIBRARIES} ${OpenMP_Fortran_LIBRARIES} $<${HAVE_FIELD_API}:field_api_${prec}> - MPI::MPI_Fortran + MPI::MPI_Fortran PUBLIC_INCLUDES $ PRIVATE_INCLUDES ${${PNAME}_OCEANMODEL_INCLUDE_DIRS} ${CMAKE_CURRENT_SOURCE_DIR} ) @@ -580,9 +560,9 @@ if( HAVE_WAM_LOKI ) MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/${ecwam}_idem_stack INSTALL_DIRECTORY module/${ecwam}_idem_stack ) - + ecwam_target_compile_definitions_FILENAME( ${ecwam}_idem_stack ) - + if( CMAKE_Fortran_COMPILER_ID MATCHES PGI|NVHPC ) target_compile_options( ${ecwam}_idem_stack PUBLIC "-Mcray=pointer" ) elseif( CMAKE_Fortran_COMPILER_ID MATCHES GNU ) @@ -593,23 +573,13 @@ if( HAVE_WAM_LOKI ) ############################################################ ## Loki SCC transformation: ## ############################################################ - foreach(src ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods}) - string(REPLACE ".F90" "" fnc ${src}) - string(CONCAT fnm "loki-scc/" ${fnc} ".scc.F90") - list(APPEND loki_scc_srcs ${fnm}) - endforeach() - - # loki_transform_convert( - # MODE scc FRONTEND ${LOKI_FRONTEND} CPP GLOBAL_VAR_OFFLOAD TRIM_VECTOR_SECTIONS - # CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki_gpu.config - # PATH ${CMAKE_CURRENT_SOURCE_DIR} - # INCLUDES ${ecwam_intfb_includes} - #  OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-scc - # OUTPUT ${loki_scc_srcs} - # DEPENDS ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods} - # ) - - loki_transform( + foreach(src ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods}) + string(REPLACE ".F90" "" fnc ${src}) + string(CONCAT fnm "loki-scc/" ${fnc} ".scc.F90") + list(APPEND loki_scc_srcs ${fnm}) + endforeach() + + loki_transform( COMMAND convert OUTPUT ${loki_scc_srcs} BUILDDIR ${CMAKE_CURRENT_BINARY_DIR}/loki-scc @@ -620,91 +590,93 @@ if( HAVE_WAM_LOKI ) FRONTEND ${LOKI_FRONTEND} SOURCES ${CMAKE_CURRENT_SOURCE_DIR} INCLUDES ${ecwam_intfb_includes} - ) - - ecbuild_add_library( - TARGET ${ecwam}_scc - TYPE ${LIBRARY_TYPE} - DEFINITIONS ${ECWAM_DEFINITIONS} WAM_PHYS_GPU - SOURCES ${ecwam_srcs} ${loki_scc_srcs} ${phys_srcs} - PUBLIC_LIBS fiat parkind_${prec} ${ecwam}_intfb - ${MPI_Fortran_LIBRARIES} - ${${PNAME}_OCEANMODEL_LIBRARIES} + ) + + ecbuild_add_library( + TARGET ${ecwam}_scc + TYPE ${LIBRARY_TYPE} + DEFINITIONS ${ECWAM_DEFINITIONS} WAM_PHYS_GPU + SOURCES ${ecwam_srcs} ${loki_scc_srcs} ${phys_srcs} + PUBLIC_LIBS fiat parkind_${prec} ${ecwam}_intfb + ${MPI_Fortran_LIBRARIES} + ${${PNAME}_OCEANMODEL_LIBRARIES} $<${HAVE_ACC}:OpenACC::OpenACC_Fortran> - PRIVATE_LIBS eccodes_f90 - ${MULTIO_LIBRARIES} - ${OpenMP_Fortran_LIBRARIES} - $<${HAVE_FIELD_API}:field_api_${prec}> - MPI::MPI_Fortran - PUBLIC_INCLUDES $ - PRIVATE_INCLUDES ${${PNAME}_OCEANMODEL_INCLUDE_DIRS} ${CMAKE_CURRENT_SOURCE_DIR} + PRIVATE_LIBS eccodes_f90 + ${MULTIO_LIBRARIES} + ${OpenMP_Fortran_LIBRARIES} + $<${HAVE_FIELD_API}:field_api_${prec}> + MPI::MPI_Fortran + PUBLIC_INCLUDES $ + PRIVATE_INCLUDES ${${PNAME}_OCEANMODEL_INCLUDE_DIRS} ${CMAKE_CURRENT_SOURCE_DIR} ) ecwam_target_fortran_module_directory( - TARGET ${ecwam}_scc - MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/${ecwam}_scc - INSTALL_DIRECTORY module/${ecwam}_scc + TARGET ${ecwam}_scc + MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/${ecwam}_scc + INSTALL_DIRECTORY module/${ecwam}_scc ) ecwam_target_compile_definitions_FILENAME( ${ecwam}_scc ) if( CMAKE_Fortran_COMPILER_ID MATCHES PGI|NVHPC AND HAVE_ACC ) - target_compile_options( ${ecwam}_scc PUBLIC "-gpu=gvmode,maxregcount:128" ) + target_compile_options( ${ecwam}_scc PUBLIC "-gpu=gvmode,maxregcount:128" ) endif() ############################################################ ## Loki SCC with pool allocator for temporaries: ## ############################################################ - #foreach(src ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods}) - # string(REPLACE ".F90" "" fnc ${src}) - # string(CONCAT fnm "loki-scc-stack/" ${fnc} ".scc_stack.F90") - # list(APPEND loki_scc_stack_srcs ${fnm}) - #endforeach() - - #loki_transform_convert( - # MODE scc-stack FRONTEND ${LOKI_FRONTEND} CPP GLOBAL_VAR_OFFLOAD TRIM_VECTOR_SECTIONS - # CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki_gpu.config - # PATH ${CMAKE_CURRENT_SOURCE_DIR} - # INCLUDES ${ecwam_intfb_includes} - # OUTPATH ${CMAKE_CURRENT_BINARY_DIR}/loki-scc-stack - # OUTPUT ${loki_scc_stack_srcs} - # DEPENDS ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods} - #) - - #ecbuild_add_library( - # TARGET ${ecwam}_scc_stack - # TYPE ${LIBRARY_TYPE} - # DEFINITIONS ${ECWAM_DEFINITIONS} WAM_PHYS_GPU - # SOURCES ${ecwam_srcs} ${loki_scc_stack_srcs} ${phys_srcs} - # PUBLIC_LIBS fiat parkind_${prec} ${ecwam}_intfb - # ${MPI_Fortran_LIBRARIES} - # ${${PNAME}_OCEANMODEL_LIBRARIES} - # $<${HAVE_ACC}:OpenACC::OpenACC_Fortran> - # PRIVATE_LIBS eccodes_f90 - # ${MULTIO_LIBRARIES} - # ${OpenMP_Fortran_LIBRARIES} - # $<${HAVE_FIELD_API}:field_api_${prec}> - # MPI::MPI_Fortran - # PUBLIC_INCLUDES $ - # PRIVATE_INCLUDES ${${PNAME}_OCEANMODEL_INCLUDE_DIRS} ${CMAKE_CURRENT_SOURCE_DIR} - #) - - #ecwam_target_fortran_module_directory( - # TARGET ${ecwam}_scc_stack - # MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/${ecwam}_scc_stack - # INSTALL_DIRECTORY module/${ecwam}_scc_stack - #) - - #ecwam_target_compile_definitions_FILENAME( ${ecwam}_scc_stack ) - - #if( CMAKE_Fortran_COMPILER_ID MATCHES PGI|NVHPC ) - # target_compile_options( ${ecwam}_scc_stack PUBLIC "-Mcray=pointer" ) - # if( HAVE_ACC ) - # target_compile_options( ${ecwam}_scc_stack PUBLIC "-gpu=gvmode,maxregcount:128" ) - # endif() - #elseif( CMAKE_Fortran_COMPILER_ID MATCHES GNU ) - # target_compile_options( ${ecwam}_scc_stack PUBLIC "-fcray-pointer" ) - #endif() + foreach(src ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods}) + string(REPLACE ".F90" "" fnc ${src}) + string(CONCAT fnm "loki-scc-stack/" ${fnc} ".scc_stack.F90") + list(APPEND loki_scc_stack_srcs ${fnm}) + endforeach() + + loki_transform( + COMMAND convert + OUTPUT ${loki_scc_stack_srcs} + BUILDDIR ${CMAKE_CURRENT_BINARY_DIR}/loki-scc-stack + DEPENDS ${phys_srcs} wamintgr_loki_gpu.F90 ${global_var_mods} + MODE scc-stack + CONFIG ${CMAKE_CURRENT_SOURCE_DIR}/ecwam_loki_gpu.config + CPP GLOBAL_VAR_OFFLOAD TRIM_VECTOR_SECTIONS + FRONTEND ${LOKI_FRONTEND} + SOURCES ${CMAKE_CURRENT_SOURCE_DIR} + INCLUDES ${ecwam_intfb_includes} + ) + ecbuild_add_library( + TARGET ${ecwam}_scc_stack + TYPE ${LIBRARY_TYPE} + DEFINITIONS ${ECWAM_DEFINITIONS} WAM_PHYS_GPU + SOURCES ${ecwam_srcs} ${loki_scc_stack_srcs} ${phys_srcs} + PUBLIC_LIBS fiat parkind_${prec} ${ecwam}_intfb + ${MPI_Fortran_LIBRARIES} + ${${PNAME}_OCEANMODEL_LIBRARIES} + $<${HAVE_ACC}:OpenACC::OpenACC_Fortran> + PRIVATE_LIBS eccodes_f90 + ${MULTIO_LIBRARIES} + ${OpenMP_Fortran_LIBRARIES} + $<${HAVE_FIELD_API}:field_api_${prec}> + MPI::MPI_Fortran + PUBLIC_INCLUDES $ + PRIVATE_INCLUDES ${${PNAME}_OCEANMODEL_INCLUDE_DIRS} ${CMAKE_CURRENT_SOURCE_DIR} + ) + + ecwam_target_fortran_module_directory( + TARGET ${ecwam}_scc_stack + MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/${ecwam}_scc_stack + INSTALL_DIRECTORY module/${ecwam}_scc_stack + ) + + ecwam_target_compile_definitions_FILENAME( ${ecwam}_scc_stack ) + + if( CMAKE_Fortran_COMPILER_ID MATCHES PGI|NVHPC ) + target_compile_options( ${ecwam}_scc_stack PUBLIC "-Mcray=pointer" ) + if( HAVE_ACC ) + target_compile_options( ${ecwam}_scc_stack PUBLIC "-gpu=gvmode,maxregcount:128" ) + endif() + elseif( CMAKE_Fortran_COMPILER_ID MATCHES GNU ) + target_compile_options( ${ecwam}_scc_stack PUBLIC "-fcray-pointer" ) + endif() endif() endif() @@ -721,29 +693,29 @@ if( HAVE_CUDA ) set_source_files_properties( ${wam_scc_cuf_srcs} PROPERTIES COMPILE_OPTIONS "-Mcuda=maxregcount:128" ) ecbuild_add_library( - TARGET ${ecwam}_scc_cuf - TYPE ${LIBRARY_TYPE} - DEFINITIONS ${ECWAM_DEFINITIONS} WAM_CUDA - SOURCES ${ecwam_srcs} ${wam_scc_cuf_srcs} ${phys_srcs} - PUBLIC_LIBS fiat parkind_${prec} ${ecwam}_intfb - ${MPI_Fortran_LIBRARIES} - ${${PNAME}_OCEANMODEL_LIBRARIES} + TARGET ${ecwam}_scc_cuf + TYPE ${LIBRARY_TYPE} + DEFINITIONS ${ECWAM_DEFINITIONS} WAM_CUDA + SOURCES ${ecwam_srcs} ${wam_scc_cuf_srcs} ${phys_srcs} + PUBLIC_LIBS fiat parkind_${prec} ${ecwam}_intfb + ${MPI_Fortran_LIBRARIES} + ${${PNAME}_OCEANMODEL_LIBRARIES} $<${HAVE_ACC}:OpenACC::OpenACC_Fortran> - PRIVATE_LIBS eccodes_f90 - ${MULTIO_LIBRARIES} - ${OpenMP_Fortran_LIBRARIES} - $<${HAVE_FIELD_API}:field_api_${prec}> - MPI::MPI_Fortran - PUBLIC_INCLUDES $ - PRIVATE_INCLUDES ${${PNAME}_OCEANMODEL_INCLUDE_DIRS} ${CMAKE_CURRENT_SOURCE_DIR} + PRIVATE_LIBS eccodes_f90 + ${MULTIO_LIBRARIES} + ${OpenMP_Fortran_LIBRARIES} + $<${HAVE_FIELD_API}:field_api_${prec}> + MPI::MPI_Fortran + PUBLIC_INCLUDES $ + PRIVATE_INCLUDES ${${PNAME}_OCEANMODEL_INCLUDE_DIRS} ${CMAKE_CURRENT_SOURCE_DIR} ) ecwam_target_fortran_module_directory( - TARGET ${ecwam}_scc_cuf - MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/${ecwam}_scc_cuf - INSTALL_DIRECTORY module/${ecwam}_scc_cuf + TARGET ${ecwam}_scc_cuf + MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/${ecwam}_scc_cuf + INSTALL_DIRECTORY module/${ecwam}_scc_cuf ) - + ecwam_target_compile_definitions_FILENAME( ${ecwam}_scc_cuf ) target_link_options( ${ecwam}_scc_cuf PUBLIC "-cuda;-gpu=pinned" ) diff --git a/src/programs/CMakeLists.txt b/src/programs/CMakeLists.txt index 7e921e4a7..63865b91a 100644 --- a/src/programs/CMakeLists.txt +++ b/src/programs/CMakeLists.txt @@ -46,12 +46,12 @@ if( HAVE_WAM_LOKI ) ) ecwam_target_compile_definitions_FILENAME(${PROJECT_NAME}-chief-loki-scc) - # ecbuild_add_executable( - # TARGET ${PROJECT_NAME}-chief-loki-scc-stack - # SOURCES chief.F90 - # LIBS ${PROJECT_NAME}_scc_stack ${OpenMP_Fortran_LIBRARIES} - # ) - # ecwam_target_compile_definitions_FILENAME(${PROJECT_NAME}-chief-loki-scc-stack) + ecbuild_add_executable( + TARGET ${PROJECT_NAME}-chief-loki-scc-stack + SOURCES chief.F90 + LIBS ${PROJECT_NAME}_scc_stack ${OpenMP_Fortran_LIBRARIES} + ) + ecwam_target_compile_definitions_FILENAME(${PROJECT_NAME}-chief-loki-scc-stack) endif() endif() From ec0d2f9ea4eb6738314cb12e3f93c7c22b1cc2a0 Mon Sep 17 00:00:00 2001 From: Balthasar Reuter Date: Mon, 12 Feb 2024 19:10:49 +0000 Subject: [PATCH 3/5] Prune Loki config files --- src/ecwam/ecwam_loki.config | 45 ++++++++---------------------- src/ecwam/ecwam_loki_gpu.config | 49 ++++++++------------------------- 2 files changed, 22 insertions(+), 72 deletions(-) diff --git a/src/ecwam/ecwam_loki.config b/src/ecwam/ecwam_loki.config index e88542a56..829822b30 100644 --- a/src/ecwam/ecwam_loki.config +++ b/src/ecwam/ecwam_loki.config @@ -3,31 +3,22 @@ mode = "idem" role = "kernel" expand = true strict = true + # Ensure that we are never adding these to the tree, and thus # do not attempt to look up the source files for these. -#disable = [ -# "DR_HOOK", "lhook", "jphook", "omp_get_wtime", "flush", "jwim", -# "jwrb", "jwru", "jwro", "environment", "frequency", -# "forcing_fields", "intgt_param_fields", "wave2ocean", "abort1", -# "iu06" -#] -# , 'dr_hook', 'lhook', 'jphook', ' - -disable = ['yomhook', 'abort', 'wave2ocean', 'intgt_param_fields', - 'forcing_fields', 'environment', 'yomgstats', 'gstats', 'gstats_barrier', 'frequency_field', - 'environment_field', 'source_contribs_field', 'intgt_param_fields', - 'source_contribs_field', 'system_clock', 'ec_parkind', 'parkind_wave', 'parkind1', - 'wam_multio_mod', 'flush', 'yowabort', 'mpl_module', 'yowtest', 'oml_mod', - 'ieee_arithmetic', 'outwspec_io_serv_handler', 'outint_io_serv_handler', - 'ifstowam_handler', 'mfeb_length', 'mon', 'isamesign', 'cdm', 'abor1', 'abort1', 'abort1_mod', - 'yowfield_mod', 'ctuw_mod', 'wam_user_clock', - 'propag_wam', 'newwind', 'incdate'] +disable = [ + 'yomhook', 'abor1', 'abort1', 'gstats', 'yowgstats', 'wam_user_clock', + 'parkind1', 'propag_wam', 'newwind', 'oml_mod', 'field_module', 'incdate', + 'ieee_arithmetic', # intrinsic modules (should have INTRINSIC in their USE statement) + 'mfeb_length', 'cdm', # internal functions + 'outwspec_io_serv_handler', 'outint_io_serv_handler', 'ifstowam_handler', # procedure pointers + '*%init', '*%update_view', '*%final', '*%ensure_host', '*%update_device' +] # Prune the tree for these to ensure they are not processed by transformations -block = ['ec_parkind', 'parkind_wave', 'parkind1', 'mfeb_length', 'mon', 'isamesign'] # , 'yoecldp', 'fc*_mod'] +block = ['ec_parkind', 'parkind_wave'] utility_routines = ['dr_hook', 'abort1', 'write(iu06'] -enable_imports = false # Define entry point for call-tree transformation [routines] @@ -38,21 +29,7 @@ enable_imports = false [routines.wamintgr] role = "driver" expand = true - # disable = [ - # "PROPAG_WAM", "NEWWIND", "GSTATS", "FREQUENCY_FIELD%INIT", - # "ENVIRONMENT_FIELD%INIT", "FORCING_FIELDS_FIELD%INIT", - # "WAVE2OCEAN_FIELD%INIT", "INTGT_PARAM_FIELDS_FIELD%INIT", - # "FREQUENCY_FIELD%UPDATE_VIEW", "ENVIRONMENT_FIELD%UPDATE_VIEW", - # "FORCING_FIELDS_FIELD%UPDATE_VIEW", "WAVE2OCEAN_FIELD%UPDATE_VIEW", - # "INTGT_PARAM_FIELDS_FIELD%UPDATE_VIEW", - # "SOURCE_CONTRIBS_FIELD%INIT", "SOURCE_CONTRIBS_FIELD%UPDATE_VIEW", - # "INCDATE", "DR_HOOK", "omp_get_wtime", "abort1", "wam_user_clock", - # "FREQUENCY_FIELD%FINAL", "ENVIRONMENT_FIELD%FINAL", - # "FORCING_FIELDS_FIELD%FINAL", "WAVE2OCEAN_FIELD%FINAL", - # "INTGT_PARAM_FIELDS_FIELD%FINAL", "SOURCE_CONTRIBS_FIELD%INIT", - #  "SOURCE_CONTRIBS_FIELD%FINAL" - # ] - real_kind = 'JWRB' + real_kind = 'JWRB' # Define indices and bounds for array dimensions [dimensions] diff --git a/src/ecwam/ecwam_loki_gpu.config b/src/ecwam/ecwam_loki_gpu.config index 5dc4ff6af..6e52ec5a2 100644 --- a/src/ecwam/ecwam_loki_gpu.config +++ b/src/ecwam/ecwam_loki_gpu.config @@ -3,29 +3,22 @@ mode = "idem" role = "kernel" expand = true strict = true -#disable = [ -# "DR_HOOK", "lhook", "jphook", "omp_get_wtime", "flush", "jwim", -# "jwrb", "jwru", "jwro", "environment", "frequency", -# "forcing_fields", "intgt_param_fields", "wave2ocean", "abort1", -# "iu06" -#] -# , 'dr_hook', 'lhook', 'jphook', ' -disable = ['yomhook', 'abort', 'wave2ocean', 'intgt_param_fields', - 'forcing_fields', 'environment', 'yomgstats', 'gstats', 'gstats_barrier', 'frequency_field', - 'environment_field', 'source_contribs_field', 'intgt_param_fields', - 'source_contribs_field', 'system_clock', 'ec_parkind', 'parkind_wave', 'parkind1', - 'wam_multio_mod', 'flush', 'yowabort', 'mpl_module', 'yowtest', 'oml_mod', - 'ieee_arithmetic', 'outwspec_io_serv_handler', 'outint_io_serv_handler', - 'ifstowam_handler', 'mfeb_length', 'mon', 'isamesign', 'cdm', 'abor1', 'abort1', 'abort1_mod', - 'yowfield_mod', 'ctuw_mod', 'wam_user_clock', - 'propag_wam', 'newwind', 'incdate'] +# Ensure that we are never adding these to the tree, and thus +# do not attempt to look up the source files for these. +disable = [ + 'yomhook', 'abor1', 'abort1', 'gstats', 'yowgstats', 'wam_user_clock', + 'parkind1', 'propag_wam', 'newwind', 'oml_mod', 'field_module', 'incdate', + 'ieee_arithmetic', # intrinsic modules (should have INTRINSIC in their USE statement) + 'mfeb_length', 'cdm', # internal functions + 'outwspec_io_serv_handler', 'outint_io_serv_handler', 'ifstowam_handler', # procedure pointers + '*%init', '*%update_view', '*%final', '*%ensure_host', '*%update_device' +] # Prune the tree for these to ensure they are not processed by transformations -block = ['ec_parkind', 'parkind_wave', 'parkind1', 'mfeb_length'] # , 'yoecldp', 'fc*_mod'] +block = ['ec_parkind', 'parkind_wave'] utility_routines = ['dr_hook', 'abort1', 'write(iu06'] -enable_imports = true # Define entry point for call-tree transformation [routines] @@ -36,26 +29,6 @@ enable_imports = true [routines.wamintgr_loki_gpu] role = "driver" expand = true - # disable = [ - # "PROPAG_WAM", "NEWWIND", "GSTATS", "FREQUENCY_FIELD%INIT", - # "ENVIRONMENT_FIELD%INIT", "FORCING_FIELDS_FIELD%INIT", - # "WAVE2OCEAN_FIELD%INIT", "INTGT_PARAM_FIELDS_FIELD%INIT", - # "FREQUENCY_FIELD%UPDATE_DEVICE", "ENVIRONMENT_FIELD%UPDATE_DEVICE", - # "FORCING_FIELDS_FIELD%UPDATE_DEVICE", - # "WAVE2OCEAN_FIELD%UPDATE_DEVICE", - # "INTGT_PARAM_FIELDS_FIELD%UPDATE_DEVICE", - # "SOURCE_CONTRIBS_FIELD%INIT", "SOURCE_CONTRIBS_FIELD%UPDATE_DEVICE", - # "INCDATE", "DR_HOOK", "omp_get_wtime", "abort1", "wam_user_clock", - # "FREQUENCY_FIELD%ENSURE_HOST", "ENVIRONMENT_FIELD%ENSURE_HOST", - # "FORCING_FIELDS_FIELD%ENSURE_HOST", "WAVE2OCEAN_FIELD%ENSURE_HOST", - # "INTGT_PARAM_FIELDS_FIELD%ENSURE_HOST", - # "SOURCE_CONTRIBS_FIELD%INIT", "SOURCE_CONTRIBS_FIELD%ENSURE_HOST", - # "FREQUENCY_FIELD%FINAL", "ENVIRONMENT_FIELD%FINAL", - # "FORCING_FIELDS_FIELD%FINAL", "WAVE2OCEAN_FIELD%FINAL", - # "INTGT_PARAM_FIELDS_FIELD%FINAL", "SOURCE_CONTRIBS_FIELD%INIT", - # "SOURCE_CONTRIBS_FIELD%FINAL" - # ] - # enable_imports = false real_kind = 'JWRB' # Define indices and bounds for array dimensions From 2170f199a28ca01737b433d7f3ab7b46c9bb6032 Mon Sep 17 00:00:00 2001 From: Ahmad Nawab Date: Wed, 28 Feb 2024 10:52:15 +0100 Subject: [PATCH 4/5] Remove pre-expanded field_module.F90 --- src/ecwam/CMakeLists.txt | 4 - src/ecwam/field_module.F90 | 6777 ------------------------------------ 2 files changed, 6781 deletions(-) delete mode 100644 src/ecwam/field_module.F90 diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 3002deef0..671ed3616 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -360,10 +360,6 @@ else() list( APPEND ecwam_srcs yowfield_mod.F90) endif() -if( NOT HAVE_FIELD_API ) - list( APPEND ecwam_srcs field_module.F90) -endif() - unset( MPI_Fortran_LIBRARIES ) if( HAVE_UNWAM ) list(APPEND ecwam_srcs ${unwam_srcs}) diff --git a/src/ecwam/field_module.F90 b/src/ecwam/field_module.F90 deleted file mode 100644 index 08a2cc14d..000000000 --- a/src/ecwam/field_module.F90 +++ /dev/null @@ -1,6777 +0,0 @@ -! (C) Copyright 2022- ECMWF. -! (C) Copyright 2022- Meteo-France. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. -! - -! Rank and shape definitions for simple templating -! -! Note that the ranks encode coneptual dimensions here, eg. FIELD_2D encodes -! a surface field and FIELD_3D represents a field with a vertical component. -MODULE FIELD_MODULE - ! The FIELD types provided by this module provide data abstractions that - ! decouple data storage in memory from the data views used in thread-parallel - ! sections of the code. They are intended to thinly wrap ATLAS_FIELD - ! objects and provide additional features that may later be - ! incorporated into Atlas. They can also provide backward-compatibility - ! for non-Atlas execution modes. - -USE PARKIND1, ONLY: JPIM, JPRB, JPLM -USE OML_MOD, ONLY: OML_MAX_THREADS, OML_MY_THREAD -USE IEEE_ARITHMETIC, ONLY: IEEE_SIGNALING_NAN - - -IMPLICIT NONE - -INTEGER (KIND=JPIM), PARAMETER :: NDEVFRESH = INT(B'00000001', JPIM), NHSTFRESH = INT(B'00000010', JPIM) -INTEGER (KIND=JPIM), PARAMETER, PRIVATE :: NH2D = 1, ND2H = 2, NRD = INT(B'00000001', JPIM), NWR = INT(B'00000010', JPIM) - - -TYPE, ABSTRACT :: FIELD_2D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - REAL(KIND=JPRB), POINTER :: PTR(:,:) => NULL() - REAL(KIND=JPRB), POINTER, CONTIGUOUS :: DEVPTR(:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_2D_FINAL - PROCEDURE :: FIELD_2D_FINAL - PROCEDURE :: GET_VIEW => FIELD_2D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_2D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_2D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_2D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_2D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_2D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_2D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_2D_GET_HOST_DATA -END TYPE FIELD_2D - -TYPE, EXTENDS(FIELD_2D) :: FIELD_2D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_2D_WRAP - PROCEDURE :: FINAL => FIELD_2D_WRAPPER_FINAL -END TYPE FIELD_2D_WRAPPER - -TYPE, EXTENDS(FIELD_2D) :: FIELD_2D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_2D_ALLOCATE - PROCEDURE :: FINAL => FIELD_2D_OWNER_FINAL -END TYPE FIELD_2D_OWNER - -TYPE, EXTENDS(FIELD_2D) :: FIELD_2D_WRAPPER_PACKED - REAL(KIND=JPRB), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_2D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_2D_WRAPPER_PACKED_FINAL -END TYPE FIELD_2D_WRAPPER_PACKED - -TYPE FIELD_2D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_2D), POINTER :: PTR => NULL() -END TYPE FIELD_2D_PTR - -TYPE FIELD_2D_VIEW - ! Struct to hold array views, so we can make arrays of them - REAL(KIND=JPRB), POINTER :: P(:) => NULL() -END TYPE FIELD_2D_VIEW - -TYPE, ABSTRACT :: FIELD_3D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - REAL(KIND=JPRB), POINTER :: PTR(:,:,:) => NULL() - REAL(KIND=JPRB), POINTER, CONTIGUOUS :: DEVPTR(:,:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_3D_FINAL - PROCEDURE :: FIELD_3D_FINAL - PROCEDURE :: GET_VIEW => FIELD_3D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_3D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_3D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_3D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_3D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_3D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_3D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_3D_GET_HOST_DATA -END TYPE FIELD_3D - -TYPE, EXTENDS(FIELD_3D) :: FIELD_3D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_3D_WRAP - PROCEDURE :: FINAL => FIELD_3D_WRAPPER_FINAL -END TYPE FIELD_3D_WRAPPER - -TYPE, EXTENDS(FIELD_3D) :: FIELD_3D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_3D_ALLOCATE - PROCEDURE :: FINAL => FIELD_3D_OWNER_FINAL -END TYPE FIELD_3D_OWNER - -TYPE, EXTENDS(FIELD_3D) :: FIELD_3D_WRAPPER_PACKED - REAL(KIND=JPRB), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_3D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_3D_WRAPPER_PACKED_FINAL -END TYPE FIELD_3D_WRAPPER_PACKED - -TYPE FIELD_3D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_3D), POINTER :: PTR => NULL() -END TYPE FIELD_3D_PTR - -TYPE FIELD_3D_VIEW - ! Struct to hold array views, so we can make arrays of them - REAL(KIND=JPRB), POINTER :: P(:,:) => NULL() -END TYPE FIELD_3D_VIEW - -TYPE, ABSTRACT :: FIELD_4D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - REAL(KIND=JPRB), POINTER :: PTR(:,:,:,:) => NULL() - REAL(KIND=JPRB), POINTER, CONTIGUOUS :: DEVPTR(:,:,:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_4D_FINAL - PROCEDURE :: FIELD_4D_FINAL - PROCEDURE :: GET_VIEW => FIELD_4D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_4D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_4D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_4D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_4D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_4D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_4D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_4D_GET_HOST_DATA -END TYPE FIELD_4D - -TYPE, EXTENDS(FIELD_4D) :: FIELD_4D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_4D_WRAP - PROCEDURE :: FINAL => FIELD_4D_WRAPPER_FINAL -END TYPE FIELD_4D_WRAPPER - -TYPE, EXTENDS(FIELD_4D) :: FIELD_4D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_4D_ALLOCATE - PROCEDURE :: FINAL => FIELD_4D_OWNER_FINAL -END TYPE FIELD_4D_OWNER - -TYPE, EXTENDS(FIELD_4D) :: FIELD_4D_WRAPPER_PACKED - REAL(KIND=JPRB), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_4D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_4D_WRAPPER_PACKED_FINAL -END TYPE FIELD_4D_WRAPPER_PACKED - -TYPE FIELD_4D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_4D), POINTER :: PTR => NULL() -END TYPE FIELD_4D_PTR - -TYPE FIELD_4D_VIEW - ! Struct to hold array views, so we can make arrays of them - REAL(KIND=JPRB), POINTER :: P(:,:,:) => NULL() -END TYPE FIELD_4D_VIEW - -TYPE, ABSTRACT :: FIELD_5D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - REAL(KIND=JPRB), POINTER :: PTR(:,:,:,:,:) => NULL() - REAL(KIND=JPRB), POINTER, CONTIGUOUS :: DEVPTR(:,:,:,:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_5D_FINAL - PROCEDURE :: FIELD_5D_FINAL - PROCEDURE :: GET_VIEW => FIELD_5D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_5D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_5D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_5D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_5D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_5D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_5D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_5D_GET_HOST_DATA -END TYPE FIELD_5D - -TYPE, EXTENDS(FIELD_5D) :: FIELD_5D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_5D_WRAP - PROCEDURE :: FINAL => FIELD_5D_WRAPPER_FINAL -END TYPE FIELD_5D_WRAPPER - -TYPE, EXTENDS(FIELD_5D) :: FIELD_5D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_5D_ALLOCATE - PROCEDURE :: FINAL => FIELD_5D_OWNER_FINAL -END TYPE FIELD_5D_OWNER - -TYPE, EXTENDS(FIELD_5D) :: FIELD_5D_WRAPPER_PACKED - REAL(KIND=JPRB), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:,:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_5D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_5D_WRAPPER_PACKED_FINAL -END TYPE FIELD_5D_WRAPPER_PACKED - -TYPE FIELD_5D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_5D), POINTER :: PTR => NULL() -END TYPE FIELD_5D_PTR - -TYPE FIELD_5D_VIEW - ! Struct to hold array views, so we can make arrays of them - REAL(KIND=JPRB), POINTER :: P(:,:,:,:) => NULL() -END TYPE FIELD_5D_VIEW - -TYPE, ABSTRACT :: FIELD_INT2D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - INTEGER(KIND=JPIM), POINTER :: PTR(:,:) => NULL() - INTEGER(KIND=JPIM), POINTER, CONTIGUOUS :: DEVPTR(:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_INT2D_FINAL - PROCEDURE :: FIELD_INT2D_FINAL - PROCEDURE :: GET_VIEW => FIELD_INT2D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_INT2D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_INT2D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_INT2D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_INT2D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_INT2D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_INT2D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_INT2D_GET_HOST_DATA -END TYPE FIELD_INT2D - -TYPE, EXTENDS(FIELD_INT2D) :: FIELD_INT2D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_INT2D_WRAP - PROCEDURE :: FINAL => FIELD_INT2D_WRAPPER_FINAL -END TYPE FIELD_INT2D_WRAPPER - -TYPE, EXTENDS(FIELD_INT2D) :: FIELD_INT2D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_INT2D_ALLOCATE - PROCEDURE :: FINAL => FIELD_INT2D_OWNER_FINAL -END TYPE FIELD_INT2D_OWNER - -TYPE, EXTENDS(FIELD_INT2D) :: FIELD_INT2D_WRAPPER_PACKED - INTEGER(KIND=JPIM), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_INT2D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_INT2D_WRAPPER_PACKED_FINAL -END TYPE FIELD_INT2D_WRAPPER_PACKED - -TYPE FIELD_INT2D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_INT2D), POINTER :: PTR => NULL() -END TYPE FIELD_INT2D_PTR - -TYPE FIELD_INT2D_VIEW - ! Struct to hold array views, so we can make arrays of them - INTEGER(KIND=JPIM), POINTER :: P(:) => NULL() -END TYPE FIELD_INT2D_VIEW - -TYPE, ABSTRACT :: FIELD_INT3D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - INTEGER(KIND=JPIM), POINTER :: PTR(:,:,:) => NULL() - INTEGER(KIND=JPIM), POINTER, CONTIGUOUS :: DEVPTR(:,:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_INT3D_FINAL - PROCEDURE :: FIELD_INT3D_FINAL - PROCEDURE :: GET_VIEW => FIELD_INT3D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_INT3D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_INT3D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_INT3D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_INT3D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_INT3D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_INT3D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_INT3D_GET_HOST_DATA -END TYPE FIELD_INT3D - -TYPE, EXTENDS(FIELD_INT3D) :: FIELD_INT3D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_INT3D_WRAP - PROCEDURE :: FINAL => FIELD_INT3D_WRAPPER_FINAL -END TYPE FIELD_INT3D_WRAPPER - -TYPE, EXTENDS(FIELD_INT3D) :: FIELD_INT3D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_INT3D_ALLOCATE - PROCEDURE :: FINAL => FIELD_INT3D_OWNER_FINAL -END TYPE FIELD_INT3D_OWNER - -TYPE, EXTENDS(FIELD_INT3D) :: FIELD_INT3D_WRAPPER_PACKED - INTEGER(KIND=JPIM), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_INT3D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_INT3D_WRAPPER_PACKED_FINAL -END TYPE FIELD_INT3D_WRAPPER_PACKED - -TYPE FIELD_INT3D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_INT3D), POINTER :: PTR => NULL() -END TYPE FIELD_INT3D_PTR - -TYPE FIELD_INT3D_VIEW - ! Struct to hold array views, so we can make arrays of them - INTEGER(KIND=JPIM), POINTER :: P(:,:) => NULL() -END TYPE FIELD_INT3D_VIEW - -TYPE, ABSTRACT :: FIELD_INT4D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - INTEGER(KIND=JPIM), POINTER :: PTR(:,:,:,:) => NULL() - INTEGER(KIND=JPIM), POINTER, CONTIGUOUS :: DEVPTR(:,:,:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_INT4D_FINAL - PROCEDURE :: FIELD_INT4D_FINAL - PROCEDURE :: GET_VIEW => FIELD_INT4D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_INT4D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_INT4D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_INT4D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_INT4D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_INT4D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_INT4D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_INT4D_GET_HOST_DATA -END TYPE FIELD_INT4D - -TYPE, EXTENDS(FIELD_INT4D) :: FIELD_INT4D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_INT4D_WRAP - PROCEDURE :: FINAL => FIELD_INT4D_WRAPPER_FINAL -END TYPE FIELD_INT4D_WRAPPER - -TYPE, EXTENDS(FIELD_INT4D) :: FIELD_INT4D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_INT4D_ALLOCATE - PROCEDURE :: FINAL => FIELD_INT4D_OWNER_FINAL -END TYPE FIELD_INT4D_OWNER - -TYPE, EXTENDS(FIELD_INT4D) :: FIELD_INT4D_WRAPPER_PACKED - INTEGER(KIND=JPIM), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_INT4D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_INT4D_WRAPPER_PACKED_FINAL -END TYPE FIELD_INT4D_WRAPPER_PACKED - -TYPE FIELD_INT4D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_INT4D), POINTER :: PTR => NULL() -END TYPE FIELD_INT4D_PTR - -TYPE FIELD_INT4D_VIEW - ! Struct to hold array views, so we can make arrays of them - INTEGER(KIND=JPIM), POINTER :: P(:,:,:) => NULL() -END TYPE FIELD_INT4D_VIEW - -TYPE, ABSTRACT :: FIELD_INT5D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - INTEGER(KIND=JPIM), POINTER :: PTR(:,:,:,:,:) => NULL() - INTEGER(KIND=JPIM), POINTER, CONTIGUOUS :: DEVPTR(:,:,:,:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_INT5D_FINAL - PROCEDURE :: FIELD_INT5D_FINAL - PROCEDURE :: GET_VIEW => FIELD_INT5D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_INT5D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_INT5D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_INT5D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_INT5D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_INT5D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_INT5D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_INT5D_GET_HOST_DATA -END TYPE FIELD_INT5D - -TYPE, EXTENDS(FIELD_INT5D) :: FIELD_INT5D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_INT5D_WRAP - PROCEDURE :: FINAL => FIELD_INT5D_WRAPPER_FINAL -END TYPE FIELD_INT5D_WRAPPER - -TYPE, EXTENDS(FIELD_INT5D) :: FIELD_INT5D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_INT5D_ALLOCATE - PROCEDURE :: FINAL => FIELD_INT5D_OWNER_FINAL -END TYPE FIELD_INT5D_OWNER - -TYPE, EXTENDS(FIELD_INT5D) :: FIELD_INT5D_WRAPPER_PACKED - INTEGER(KIND=JPIM), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:,:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_INT5D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_INT5D_WRAPPER_PACKED_FINAL -END TYPE FIELD_INT5D_WRAPPER_PACKED - -TYPE FIELD_INT5D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_INT5D), POINTER :: PTR => NULL() -END TYPE FIELD_INT5D_PTR - -TYPE FIELD_INT5D_VIEW - ! Struct to hold array views, so we can make arrays of them - INTEGER(KIND=JPIM), POINTER :: P(:,:,:,:) => NULL() -END TYPE FIELD_INT5D_VIEW - -TYPE, ABSTRACT :: FIELD_LOG2D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:) => NULL() - LOGICAL(KIND=JPLM), POINTER, CONTIGUOUS :: DEVPTR(:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_LOG2D_FINAL - PROCEDURE :: FIELD_LOG2D_FINAL - PROCEDURE :: GET_VIEW => FIELD_LOG2D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_LOG2D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_LOG2D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_LOG2D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_LOG2D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_LOG2D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_LOG2D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_LOG2D_GET_HOST_DATA -END TYPE FIELD_LOG2D - -TYPE, EXTENDS(FIELD_LOG2D) :: FIELD_LOG2D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_LOG2D_WRAP - PROCEDURE :: FINAL => FIELD_LOG2D_WRAPPER_FINAL -END TYPE FIELD_LOG2D_WRAPPER - -TYPE, EXTENDS(FIELD_LOG2D) :: FIELD_LOG2D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_LOG2D_ALLOCATE - PROCEDURE :: FINAL => FIELD_LOG2D_OWNER_FINAL -END TYPE FIELD_LOG2D_OWNER - -TYPE, EXTENDS(FIELD_LOG2D) :: FIELD_LOG2D_WRAPPER_PACKED - LOGICAL(KIND=JPLM), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_LOG2D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_LOG2D_WRAPPER_PACKED_FINAL -END TYPE FIELD_LOG2D_WRAPPER_PACKED - -TYPE FIELD_LOG2D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_LOG2D), POINTER :: PTR => NULL() -END TYPE FIELD_LOG2D_PTR - -TYPE FIELD_LOG2D_VIEW - ! Struct to hold array views, so we can make arrays of them - LOGICAL(KIND=JPLM), POINTER :: P(:) => NULL() -END TYPE FIELD_LOG2D_VIEW - -TYPE, ABSTRACT :: FIELD_LOG3D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:,:) => NULL() - LOGICAL(KIND=JPLM), POINTER, CONTIGUOUS :: DEVPTR(:,:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_LOG3D_FINAL - PROCEDURE :: FIELD_LOG3D_FINAL - PROCEDURE :: GET_VIEW => FIELD_LOG3D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_LOG3D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_LOG3D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_LOG3D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_LOG3D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_LOG3D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_LOG3D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_LOG3D_GET_HOST_DATA -END TYPE FIELD_LOG3D - -TYPE, EXTENDS(FIELD_LOG3D) :: FIELD_LOG3D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_LOG3D_WRAP - PROCEDURE :: FINAL => FIELD_LOG3D_WRAPPER_FINAL -END TYPE FIELD_LOG3D_WRAPPER - -TYPE, EXTENDS(FIELD_LOG3D) :: FIELD_LOG3D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_LOG3D_ALLOCATE - PROCEDURE :: FINAL => FIELD_LOG3D_OWNER_FINAL -END TYPE FIELD_LOG3D_OWNER - -TYPE, EXTENDS(FIELD_LOG3D) :: FIELD_LOG3D_WRAPPER_PACKED - LOGICAL(KIND=JPLM), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_LOG3D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_LOG3D_WRAPPER_PACKED_FINAL -END TYPE FIELD_LOG3D_WRAPPER_PACKED - -TYPE FIELD_LOG3D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_LOG3D), POINTER :: PTR => NULL() -END TYPE FIELD_LOG3D_PTR - -TYPE FIELD_LOG3D_VIEW - ! Struct to hold array views, so we can make arrays of them - LOGICAL(KIND=JPLM), POINTER :: P(:,:) => NULL() -END TYPE FIELD_LOG3D_VIEW - -TYPE, ABSTRACT :: FIELD_LOG4D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:,:,:) => NULL() - LOGICAL(KIND=JPLM), POINTER, CONTIGUOUS :: DEVPTR(:,:,:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_LOG4D_FINAL - PROCEDURE :: FIELD_LOG4D_FINAL - PROCEDURE :: GET_VIEW => FIELD_LOG4D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_LOG4D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_LOG4D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_LOG4D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_LOG4D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_LOG4D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_LOG4D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_LOG4D_GET_HOST_DATA -END TYPE FIELD_LOG4D - -TYPE, EXTENDS(FIELD_LOG4D) :: FIELD_LOG4D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_LOG4D_WRAP - PROCEDURE :: FINAL => FIELD_LOG4D_WRAPPER_FINAL -END TYPE FIELD_LOG4D_WRAPPER - -TYPE, EXTENDS(FIELD_LOG4D) :: FIELD_LOG4D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_LOG4D_ALLOCATE - PROCEDURE :: FINAL => FIELD_LOG4D_OWNER_FINAL -END TYPE FIELD_LOG4D_OWNER - -TYPE, EXTENDS(FIELD_LOG4D) :: FIELD_LOG4D_WRAPPER_PACKED - LOGICAL(KIND=JPLM), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_LOG4D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_LOG4D_WRAPPER_PACKED_FINAL -END TYPE FIELD_LOG4D_WRAPPER_PACKED - -TYPE FIELD_LOG4D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_LOG4D), POINTER :: PTR => NULL() -END TYPE FIELD_LOG4D_PTR - -TYPE FIELD_LOG4D_VIEW - ! Struct to hold array views, so we can make arrays of them - LOGICAL(KIND=JPLM), POINTER :: P(:,:,:) => NULL() -END TYPE FIELD_LOG4D_VIEW - -TYPE, ABSTRACT :: FIELD_LOG5D - ! A FIELD encapsulates a single multi-dimensional array and can - ! provide block-indexed "views" of the data for automating the - ! allocation and parallel iterration of NPROMA blocks. - - ! TODO: Atlas-based field data storage field - ! TODO: Do we still need to use pointers here? - ! TYPE(ATLAS_FIELD), POINTER :: DATA - - ! Storage pointer for non-Atlas backward-compatibility mode - ! - ! The underlying storage pointer has the rank as the dimension, - ! where the innermost dimension represents the horizontal and - ! the outermost one is the block index. - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:,:,:,:) => NULL() - LOGICAL(KIND=JPLM), POINTER, CONTIGUOUS :: DEVPTR(:,:,:,:,:) => NULL() - - ! Flag indicating the use a single block-buffer per thread - LOGICAL :: THREAD_BUFFER = .FALSE. - - INTEGER(KIND=JPIM) :: ISTATUS = 0 - INTEGER(KIND=JPIM) :: LAST_CONTIGUOUS_DIMENSION = 0 - - -CONTAINS - - PROCEDURE :: FINAL => FIELD_LOG5D_FINAL - PROCEDURE :: FIELD_LOG5D_FINAL - PROCEDURE :: GET_VIEW => FIELD_LOG5D_GET_VIEW - PROCEDURE :: GET_HOST_DATA_RDONLY => FIELD_LOG5D_GET_HOST_DATA_RDONLY - PROCEDURE :: GET_HOST_DATA_RDWR => FIELD_LOG5D_GET_HOST_DATA_RDWR - PROCEDURE :: GET_DEVICE_DATA_RDONLY => FIELD_LOG5D_GET_DEVICE_DATA_RDONLY - PROCEDURE :: GET_DEVICE_DATA_RDWR => FIELD_LOG5D_GET_DEVICE_DATA_RDWR - PROCEDURE :: CLONE => FIELD_LOG5D_CLONE - PROCEDURE, PRIVATE :: GET_DEVICE_DATA => FIELD_LOG5D_GET_DEVICE_DATA - PROCEDURE, PRIVATE :: GET_HOST_DATA => FIELD_LOG5D_GET_HOST_DATA -END TYPE FIELD_LOG5D - -TYPE, EXTENDS(FIELD_LOG5D) :: FIELD_LOG5D_WRAPPER -CONTAINS - PROCEDURE :: INIT => FIELD_LOG5D_WRAP - PROCEDURE :: FINAL => FIELD_LOG5D_WRAPPER_FINAL -END TYPE FIELD_LOG5D_WRAPPER - -TYPE, EXTENDS(FIELD_LOG5D) :: FIELD_LOG5D_OWNER -CONTAINS - PROCEDURE :: INIT => FIELD_LOG5D_ALLOCATE - PROCEDURE :: FINAL => FIELD_LOG5D_OWNER_FINAL -END TYPE FIELD_LOG5D_OWNER - -TYPE, EXTENDS(FIELD_LOG5D) :: FIELD_LOG5D_WRAPPER_PACKED - LOGICAL(KIND=JPLM), POINTER, CONTIGUOUS :: BASE_PTR(:,:,:,:,:,:) => NULL() - INTEGER(KIND=JPIM) :: FIDX - LOGICAL(KIND=JPLM) :: CONTIG_PACKED -CONTAINS - PROCEDURE :: INIT => FIELD_LOG5D_WRAP_PACKED - PROCEDURE :: FINAL => FIELD_LOG5D_WRAPPER_PACKED_FINAL -END TYPE FIELD_LOG5D_WRAPPER_PACKED - -TYPE FIELD_LOG5D_PTR - ! Struct to hold references to field objects - CLASS(FIELD_LOG5D), POINTER :: PTR => NULL() -END TYPE FIELD_LOG5D_PTR - -TYPE FIELD_LOG5D_VIEW - ! Struct to hold array views, so we can make arrays of them - LOGICAL(KIND=JPLM), POINTER :: P(:,:,:,:) => NULL() -END TYPE FIELD_LOG5D_VIEW - - -INTERFACE FIELD_2D - MODULE PROCEDURE :: FIELD_2D_WRAPPER_CONSTRUCTOR - MODULE PROCEDURE :: FIELD_2D_WRAPPER_PACKED_CONSTRUCTOR - MODULE PROCEDURE :: FIELD_2D_OWNER_CONSTRUCTOR -END INTERFACE - -INTERFACE FIELD_INT2D - MODULE PROCEDURE :: FIELD_INT2D_OWNER_CONSTRUCTOR -END INTERFACE - -INTERFACE FIELD_LOG2D - MODULE PROCEDURE :: FIELD_LOG2D_OWNER_CONSTRUCTOR -END INTERFACE - -INTERFACE FIELD_3D - MODULE PROCEDURE :: FIELD_3D_WRAPPER_CONSTRUCTOR - MODULE PROCEDURE :: FIELD_3D_WRAPPER_PACKED_CONSTRUCTOR - MODULE PROCEDURE :: FIELD_3D_OWNER_CONSTRUCTOR -END INTERFACE - -INTERFACE FIELD_INT3D - MODULE PROCEDURE :: FIELD_INT3D_OWNER_CONSTRUCTOR -END INTERFACE - -INTERFACE FIELD_LOG3D - MODULE PROCEDURE :: FIELD_LOG3D_OWNER_CONSTRUCTOR -END INTERFACE - -INTERFACE FIELD_4D - MODULE PROCEDURE :: FIELD_4D_WRAPPER_CONSTRUCTOR - MODULE PROCEDURE :: FIELD_4D_WRAPPER_PACKED_CONSTRUCTOR - MODULE PROCEDURE :: FIELD_4D_OWNER_CONSTRUCTOR -END INTERFACE - -INTERFACE FIELD_INT4D - MODULE PROCEDURE :: FIELD_INT4D_OWNER_CONSTRUCTOR -END INTERFACE - -INTERFACE FIELD_LOG4D - MODULE PROCEDURE :: FIELD_LOG4D_OWNER_CONSTRUCTOR -END INTERFACE - -INTERFACE FIELD_5D - MODULE PROCEDURE :: FIELD_5D_WRAPPER_CONSTRUCTOR - MODULE PROCEDURE :: FIELD_5D_WRAPPER_PACKED_CONSTRUCTOR - MODULE PROCEDURE :: FIELD_5D_OWNER_CONSTRUCTOR -END INTERFACE - -INTERFACE FIELD_INT5D - MODULE PROCEDURE :: FIELD_INT5D_OWNER_CONSTRUCTOR -END INTERFACE - -INTERFACE FIELD_LOG5D - MODULE PROCEDURE :: FIELD_LOG5D_OWNER_CONSTRUCTOR -END INTERFACE - - -CONTAINS -! -! CLASS METHODS -! - FUNCTION FIELD_2D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(1) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - - CLASS(FIELD_2D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(2) - INTEGER(KIND=JPIM) :: UBOUNDS(2) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_2D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_2D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - - CLASS(FIELD_2D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_2D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_2D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_2D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_2D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_2D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_2D_WRAPPER), INTENT(INOUT) :: SELF - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 2)) THEN - CALL ABOR1 ('FIELD_2D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_2D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_2D_WRAP - - SUBROUTINE FIELD_2D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_2D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 3 .AND. BUFFER_RANK /= 2)THEN - CALL ABOR1 ('FIELD_2D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 3) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):) => DATA(:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):) => DATA(:,IDX,:) - ELSE - SELF%PTR => DATA(:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_2D_WRAP_PACKED - - SUBROUTINE FIELD_2D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_2D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(2) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(2) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(2) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(2) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(2) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 2 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(2) = 1 - REAL_UBOUNDS(2) = UBOUNDS(2) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_2D_ALLOCATE - - FUNCTION FIELD_2D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_2D) :: SELF - REAL(KIND=JPRB), POINTER :: VIEW_PTR(:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(2) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):) => SELF%PTR(:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:) = 0.0_JPRB - END IF - END FUNCTION FIELD_2D_GET_VIEW - - FUNCTION FIELD_2D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_2D), INTENT(INOUT) :: SELF - CLASS(FIELD_2D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_2D_OWNER) - NEWOBJ => FIELD_2D_CLONE_OWNER(SELF) - TYPE IS(FIELD_2D_WRAPPER) - NEWOBJ => FIELD_2D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_2D_CLONE - - FUNCTION FIELD_2D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_2D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_2D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_2D_CLONE_WRAPPER - - FUNCTION FIELD_2D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_2D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_2D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_2D_CLONE_OWNER - - - SUBROUTINE FIELD_2D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_2D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_2D_FINAL - - SUBROUTINE FIELD_2D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_2D_WRAPPER) :: SELF - REAL(KIND=JPRB), POINTER :: PTR(:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_2D_FINAL - END SUBROUTINE FIELD_2D_WRAPPER_FINAL - - SUBROUTINE FIELD_2D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_2D_WRAPPER_PACKED) :: SELF - REAL(KIND=JPRB), POINTER :: PTR(:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_2D_FINAL - END SUBROUTINE FIELD_2D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_2D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_2D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_2D_FINAL - END SUBROUTINE FIELD_2D_OWNER_FINAL - - SUBROUTINE FIELD_2D_ENSURE_HOST(SELF) - CLASS(FIELD_2D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_2D_ENSURE_HOST - - SUBROUTINE FIELD_2D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_2D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(2) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):) => SELF%PTR (:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_2D_GET_HOST_DATA - - SUBROUTINE FIELD_2D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_2D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_2D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_2D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_2D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_2D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_2D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_2D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_2D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_2D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(2) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):) => SELF%DEVPTR(:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_2D_GET_DEVICE_DATA - - SUBROUTINE FIELD_2D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_2D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_2D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_2D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_2D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_2D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_2D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_2D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_2D_COPY (SELF, KDIR) - CLASS(FIELD_2D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_2D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:), DEV (:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2 - - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2), HST (J1, J2), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2), DEV (J1, J2), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:), DEV (:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2 - - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2), HST (LBOUND(HST, 1), J2), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2), DEV (LBOUND(HST, 1), J2), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:), DEV (:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2)), HST (LBOUND(HST, 1), LBOUND(HST, 2)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2)), DEV (LBOUND(HST, 1), LBOUND(HST, 2)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_2D_COPY - - - FUNCTION FIELD_3D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(2) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - - CLASS(FIELD_3D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(3) - INTEGER(KIND=JPIM) :: UBOUNDS(3) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = SHAPE(2) - UBOUNDS(3) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_3D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_3D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - - CLASS(FIELD_3D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_3D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_3D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_3D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_3D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_3D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_3D_WRAPPER), INTENT(INOUT) :: SELF - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 3)) THEN - CALL ABOR1 ('FIELD_3D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_3D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_3D_WRAP - - SUBROUTINE FIELD_3D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_3D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 4 .AND. BUFFER_RANK /= 3)THEN - CALL ABOR1 ('FIELD_3D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 4) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => DATA(:,:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => DATA(:,:,IDX,:) - ELSE - SELF%PTR => DATA(:,:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_3D_WRAP_PACKED - - SUBROUTINE FIELD_3D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_3D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(3) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(3) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(3) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(3) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(3) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 3 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(3) = 1 - REAL_UBOUNDS(3) = UBOUNDS(3) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2),REAL_LBOUNDS(3):REAL_UBOUNDS(3))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_3D_ALLOCATE - - FUNCTION FIELD_3D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_3D) :: SELF - REAL(KIND=JPRB), POINTER :: VIEW_PTR(:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(3) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):,LBOUNDS(2):) => SELF%PTR(:,:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:,:) = 0.0_JPRB - END IF - END FUNCTION FIELD_3D_GET_VIEW - - FUNCTION FIELD_3D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_3D), INTENT(INOUT) :: SELF - CLASS(FIELD_3D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_3D_OWNER) - NEWOBJ => FIELD_3D_CLONE_OWNER(SELF) - TYPE IS(FIELD_3D_WRAPPER) - NEWOBJ => FIELD_3D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_3D_CLONE - - FUNCTION FIELD_3D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_3D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_3D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_3D_CLONE_WRAPPER - - FUNCTION FIELD_3D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_3D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_3D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_3D_CLONE_OWNER - - - SUBROUTINE FIELD_3D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_3D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_3D_FINAL - - SUBROUTINE FIELD_3D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_3D_WRAPPER) :: SELF - REAL(KIND=JPRB), POINTER :: PTR(:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_3D_FINAL - END SUBROUTINE FIELD_3D_WRAPPER_FINAL - - SUBROUTINE FIELD_3D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_3D_WRAPPER_PACKED) :: SELF - REAL(KIND=JPRB), POINTER :: PTR(:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_3D_FINAL - END SUBROUTINE FIELD_3D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_3D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_3D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_3D_FINAL - END SUBROUTINE FIELD_3D_OWNER_FINAL - - SUBROUTINE FIELD_3D_ENSURE_HOST(SELF) - CLASS(FIELD_3D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_3D_ENSURE_HOST - - SUBROUTINE FIELD_3D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_3D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(3) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => SELF%PTR (:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_3D_GET_HOST_DATA - - SUBROUTINE FIELD_3D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_3D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_3D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_3D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_3D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_3D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_3D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_3D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_3D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_3D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(3) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => SELF%DEVPTR(:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_3D_GET_DEVICE_DATA - - SUBROUTINE FIELD_3D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_3D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_3D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_3D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_3D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_3D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_3D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_3D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_3D_COPY (SELF, KDIR) - CLASS(FIELD_3D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_3D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (3) - CALL COPY_DIM3_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2, J3 - - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2, J3), HST (J1, J2, J3), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2, J3), DEV (J1, J2, J3), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2, J3 - - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2, J3)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2, J3), HST (LBOUND(HST, 1), J2, J3), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2, J3), DEV (LBOUND(HST, 1), J2, J3), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J3 - - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - ISIZE = KIND (HST) * SIZE (HST (:, :, J3)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3), HST (LBOUND(HST, 1), LBOUND(HST, 2), J3), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), J3), DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM3_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3)), HST (LBOUND(HST, 1), LBOUND(HST, 2),& - & LBOUND(HST, 3)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3)), DEV (LBOUND(HST, 1), LBOUND(HST, 2),& - & LBOUND(HST, 3)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_3D_COPY - - - FUNCTION FIELD_4D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(3) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - - CLASS(FIELD_4D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(4) - INTEGER(KIND=JPIM) :: UBOUNDS(4) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = SHAPE(2) - UBOUNDS(3) = SHAPE(3) - UBOUNDS(4) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_4D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_4D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - - CLASS(FIELD_4D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_4D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_4D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_4D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_4D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_4D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_4D_WRAPPER), INTENT(INOUT) :: SELF - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 4)) THEN - CALL ABOR1 ('FIELD_4D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_4D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_4D_WRAP - - SUBROUTINE FIELD_4D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_4D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 5 .AND. BUFFER_RANK /= 4)THEN - CALL ABOR1 ('FIELD_4D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 5) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => DATA(:,:,:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => DATA(:,:,:,IDX,:) - ELSE - SELF%PTR => DATA(:,:,:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_4D_WRAP_PACKED - - SUBROUTINE FIELD_4D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_4D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(4) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(4) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(4) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(4) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(4) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 4 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(4) = 1 - REAL_UBOUNDS(4) = UBOUNDS(4) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2),REAL_LBOUNDS(3):REAL_UBOUNDS(3),REAL_LBOUNDS(& - &4):REAL_UBOUNDS(4))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_4D_ALLOCATE - - FUNCTION FIELD_4D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_4D) :: SELF - REAL(KIND=JPRB), POINTER :: VIEW_PTR(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(4) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):,LBOUNDS(2):,LBOUNDS(3):) => SELF%PTR(:,:,:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:,:,:) = 0.0_JPRB - END IF - END FUNCTION FIELD_4D_GET_VIEW - - FUNCTION FIELD_4D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_4D), INTENT(INOUT) :: SELF - CLASS(FIELD_4D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_4D_OWNER) - NEWOBJ => FIELD_4D_CLONE_OWNER(SELF) - TYPE IS(FIELD_4D_WRAPPER) - NEWOBJ => FIELD_4D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_4D_CLONE - - FUNCTION FIELD_4D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_4D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_4D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_4D_CLONE_WRAPPER - - FUNCTION FIELD_4D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_4D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_4D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_4D_CLONE_OWNER - - - SUBROUTINE FIELD_4D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_4D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_4D_FINAL - - SUBROUTINE FIELD_4D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_4D_WRAPPER) :: SELF - REAL(KIND=JPRB), POINTER :: PTR(:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_4D_FINAL - END SUBROUTINE FIELD_4D_WRAPPER_FINAL - - SUBROUTINE FIELD_4D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_4D_WRAPPER_PACKED) :: SELF - REAL(KIND=JPRB), POINTER :: PTR(:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_4D_FINAL - END SUBROUTINE FIELD_4D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_4D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_4D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_4D_FINAL - END SUBROUTINE FIELD_4D_OWNER_FINAL - - SUBROUTINE FIELD_4D_ENSURE_HOST(SELF) - CLASS(FIELD_4D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_4D_ENSURE_HOST - - SUBROUTINE FIELD_4D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_4D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(4) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => SELF%PTR (:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_4D_GET_HOST_DATA - - SUBROUTINE FIELD_4D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_4D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_4D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_4D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_4D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_4D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_4D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_4D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_4D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_4D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(4) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => SELF%DEVPTR(:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_4D_GET_DEVICE_DATA - - SUBROUTINE FIELD_4D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_4D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_4D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_4D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_4D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_4D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_4D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_4D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_4D_COPY (SELF, KDIR) - CLASS(FIELD_4D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_4D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (3) - CALL COPY_DIM3_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (4) - CALL COPY_DIM4_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2, J3, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2, J3, J4), HST (J1, J2, J3, J4), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2, J3, J4), DEV (J1, J2, J3, J4), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2, J3, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2, J3, J4)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2, J3, J4), HST (LBOUND(HST, 1), J2, J3, J4), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2, J3, J4), DEV (LBOUND(HST, 1), J2, J3, J4), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J3, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - ISIZE = KIND (HST) * SIZE (HST (:, :, J3, J4)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4), HST (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4),& - & ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4), DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4),& - & ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM3_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - ISIZE = KIND (HST) * SIZE (HST (:, :, :, J4)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4), HST (LBOUND(HST, 1), LBOUND(HST, 2),& - & LBOUND(HST, 3), J4), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4), DEV (LBOUND(HST, 1), LBOUND(HST,& - & 2), LBOUND(HST, 3), J4), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM4_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :, :, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), HST (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), DEV (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_4D_COPY - - - FUNCTION FIELD_5D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(4) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - - CLASS(FIELD_5D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(5) - INTEGER(KIND=JPIM) :: UBOUNDS(5) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = SHAPE(2) - UBOUNDS(3) = SHAPE(3) - UBOUNDS(4) = SHAPE(4) - UBOUNDS(5) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_5D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_5D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - - CLASS(FIELD_5D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_5D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_5D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_5D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_5D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_5D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_5D_WRAPPER), INTENT(INOUT) :: SELF - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 5)) THEN - CALL ABOR1 ('FIELD_5D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_5D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_5D_WRAP - - SUBROUTINE FIELD_5D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_5D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - REAL(KIND=JPRB), TARGET, INTENT(IN) :: DATA(:,:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 6 .AND. BUFFER_RANK /= 5)THEN - CALL ABOR1 ('FIELD_5D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 6) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => DATA(:,:,:,:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,:,:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => DATA(:,:,:,:,IDX,:) - ELSE - SELF%PTR => DATA(:,:,:,:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_5D_WRAP_PACKED - - SUBROUTINE FIELD_5D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_5D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(5) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(5) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(5) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(5) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(5) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 5 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(5) = 1 - REAL_UBOUNDS(5) = UBOUNDS(5) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2),REAL_LBOUNDS(3):REAL_UBOUNDS(3),REAL_LBOUNDS(& - &4):REAL_UBOUNDS(4),REAL_LBOUNDS(5):REAL_UBOUNDS(5))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_5D_ALLOCATE - - FUNCTION FIELD_5D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_5D) :: SELF - REAL(KIND=JPRB), POINTER :: VIEW_PTR(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(5) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):,LBOUNDS(2):,LBOUNDS(3):,LBOUNDS(4):) => SELF%PTR(:,:,:,:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:,:,:,:) = 0.0_JPRB - END IF - END FUNCTION FIELD_5D_GET_VIEW - - FUNCTION FIELD_5D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_5D), INTENT(INOUT) :: SELF - CLASS(FIELD_5D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_5D_OWNER) - NEWOBJ => FIELD_5D_CLONE_OWNER(SELF) - TYPE IS(FIELD_5D_WRAPPER) - NEWOBJ => FIELD_5D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_5D_CLONE - - FUNCTION FIELD_5D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_5D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_5D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_5D_CLONE_WRAPPER - - FUNCTION FIELD_5D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_5D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_5D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_5D_CLONE_OWNER - - - SUBROUTINE FIELD_5D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_5D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_5D_FINAL - - SUBROUTINE FIELD_5D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_5D_WRAPPER) :: SELF - REAL(KIND=JPRB), POINTER :: PTR(:,:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_5D_FINAL - END SUBROUTINE FIELD_5D_WRAPPER_FINAL - - SUBROUTINE FIELD_5D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_5D_WRAPPER_PACKED) :: SELF - REAL(KIND=JPRB), POINTER :: PTR(:,:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_5D_FINAL - END SUBROUTINE FIELD_5D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_5D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_5D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_5D_FINAL - END SUBROUTINE FIELD_5D_OWNER_FINAL - - SUBROUTINE FIELD_5D_ENSURE_HOST(SELF) - CLASS(FIELD_5D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_5D_ENSURE_HOST - - SUBROUTINE FIELD_5D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_5D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(5) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => SELF%PTR (:,:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_5D_GET_HOST_DATA - - SUBROUTINE FIELD_5D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_5D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_5D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_5D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_5D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_5D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_5D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_5D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_5D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_5D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(5) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => SELF%DEVPTR(:,:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_5D_GET_DEVICE_DATA - - SUBROUTINE FIELD_5D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_5D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_5D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_5D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_5D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_5D), INTENT (INOUT) :: SELF - REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_5D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_5D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_5D_COPY (SELF, KDIR) - CLASS(FIELD_5D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_5D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (3) - CALL COPY_DIM3_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (4) - CALL COPY_DIM4_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (5) - CALL COPY_DIM5_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2, J3, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2, J3, J4, J5), HST (J1, J2, J3, J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2, J3, J4, J5), DEV (J1, J2, J3, J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2, J3, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2, J3, J4, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2, J3, J4, J5), HST (LBOUND(HST, 1), J2, J3, J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2, J3, J4, J5), DEV (LBOUND(HST, 1), J2, J3, J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J3, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - ISIZE = KIND (HST) * SIZE (HST (:, :, J3, J4, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4, J5), HST (LBOUND(HST, 1), LBOUND(HST, 2), J3,& - & J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4, J5), DEV (LBOUND(HST, 1), LBOUND(HST, 2),& - & J3, J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM3_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - ISIZE = KIND (HST) * SIZE (HST (:, :, :, J4, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), HST (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), DEV (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM4_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - ISIZE = KIND (HST) * SIZE (HST (:, :, :, :, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), HST (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), DEV (LBOUND(HST,& - & 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM5_CONTIGUOUS (HST, DEV, KDIR) - REAL(KIND=JPRB), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :, :, :, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), HST& - & (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), DEV& - & (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_5D_COPY - - - FUNCTION FIELD_INT2D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(1) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - - CLASS(FIELD_INT2D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(2) - INTEGER(KIND=JPIM) :: UBOUNDS(2) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_INT2D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_INT2D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - - CLASS(FIELD_INT2D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_INT2D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_INT2D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_INT2D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_INT2D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_INT2D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_INT2D_WRAPPER), INTENT(INOUT) :: SELF - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 2)) THEN - CALL ABOR1 ('FIELD_INT2D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_INT2D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_INT2D_WRAP - - SUBROUTINE FIELD_INT2D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_INT2D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 3 .AND. BUFFER_RANK /= 2)THEN - CALL ABOR1 ('FIELD_INT2D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 3) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):) => DATA(:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):) => DATA(:,IDX,:) - ELSE - SELF%PTR => DATA(:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_INT2D_WRAP_PACKED - - SUBROUTINE FIELD_INT2D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_INT2D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(2) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(2) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(2) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(2) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(2) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 2 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(2) = 1 - REAL_UBOUNDS(2) = UBOUNDS(2) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_INT2D_ALLOCATE - - FUNCTION FIELD_INT2D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_INT2D) :: SELF - INTEGER(KIND=JPIM), POINTER :: VIEW_PTR(:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(2) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):) => SELF%PTR(:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:) = 0.0_JPIM - END IF - END FUNCTION FIELD_INT2D_GET_VIEW - - FUNCTION FIELD_INT2D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT2D), INTENT(INOUT) :: SELF - CLASS(FIELD_INT2D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_INT2D_OWNER) - NEWOBJ => FIELD_INT2D_CLONE_OWNER(SELF) - TYPE IS(FIELD_INT2D_WRAPPER) - NEWOBJ => FIELD_INT2D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_INT2D_CLONE - - FUNCTION FIELD_INT2D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT2D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_INT2D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_INT2D_CLONE_WRAPPER - - FUNCTION FIELD_INT2D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT2D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_INT2D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_INT2D_CLONE_OWNER - - - SUBROUTINE FIELD_INT2D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT2D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_INT2D_FINAL - - SUBROUTINE FIELD_INT2D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT2D_WRAPPER) :: SELF - INTEGER(KIND=JPIM), POINTER :: PTR(:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_INT2D_FINAL - END SUBROUTINE FIELD_INT2D_WRAPPER_FINAL - - SUBROUTINE FIELD_INT2D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT2D_WRAPPER_PACKED) :: SELF - INTEGER(KIND=JPIM), POINTER :: PTR(:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_INT2D_FINAL - END SUBROUTINE FIELD_INT2D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_INT2D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT2D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_INT2D_FINAL - END SUBROUTINE FIELD_INT2D_OWNER_FINAL - - SUBROUTINE FIELD_INT2D_ENSURE_HOST(SELF) - CLASS(FIELD_INT2D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_INT2D_ENSURE_HOST - - SUBROUTINE FIELD_INT2D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_INT2D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(2) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):) => SELF%PTR (:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_INT2D_GET_HOST_DATA - - SUBROUTINE FIELD_INT2D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_INT2D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_INT2D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_INT2D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_INT2D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_INT2D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_INT2D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_INT2D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_INT2D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_INT2D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(2) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):) => SELF%DEVPTR(:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_INT2D_GET_DEVICE_DATA - - SUBROUTINE FIELD_INT2D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_INT2D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_INT2D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_INT2D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_INT2D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_INT2D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_INT2D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_INT2D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_INT2D_COPY (SELF, KDIR) - CLASS(FIELD_INT2D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_INT2D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:), DEV (:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2 - - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2), HST (J1, J2), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2), DEV (J1, J2), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:), DEV (:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2 - - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2), HST (LBOUND(HST, 1), J2), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2), DEV (LBOUND(HST, 1), J2), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:), DEV (:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2)), HST (LBOUND(HST, 1), LBOUND(HST, 2)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2)), DEV (LBOUND(HST, 1), LBOUND(HST, 2)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_INT2D_COPY - - - FUNCTION FIELD_INT3D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(2) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - - CLASS(FIELD_INT3D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(3) - INTEGER(KIND=JPIM) :: UBOUNDS(3) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = SHAPE(2) - UBOUNDS(3) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_INT3D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_INT3D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - - CLASS(FIELD_INT3D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_INT3D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_INT3D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_INT3D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_INT3D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_INT3D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_INT3D_WRAPPER), INTENT(INOUT) :: SELF - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 3)) THEN - CALL ABOR1 ('FIELD_INT3D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_INT3D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_INT3D_WRAP - - SUBROUTINE FIELD_INT3D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_INT3D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 4 .AND. BUFFER_RANK /= 3)THEN - CALL ABOR1 ('FIELD_INT3D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 4) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => DATA(:,:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => DATA(:,:,IDX,:) - ELSE - SELF%PTR => DATA(:,:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_INT3D_WRAP_PACKED - - SUBROUTINE FIELD_INT3D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_INT3D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(3) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(3) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(3) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(3) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(3) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 3 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(3) = 1 - REAL_UBOUNDS(3) = UBOUNDS(3) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2),REAL_LBOUNDS(3):REAL_UBOUNDS(3))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_INT3D_ALLOCATE - - FUNCTION FIELD_INT3D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_INT3D) :: SELF - INTEGER(KIND=JPIM), POINTER :: VIEW_PTR(:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(3) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):,LBOUNDS(2):) => SELF%PTR(:,:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:,:) = 0.0_JPIM - END IF - END FUNCTION FIELD_INT3D_GET_VIEW - - FUNCTION FIELD_INT3D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT3D), INTENT(INOUT) :: SELF - CLASS(FIELD_INT3D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_INT3D_OWNER) - NEWOBJ => FIELD_INT3D_CLONE_OWNER(SELF) - TYPE IS(FIELD_INT3D_WRAPPER) - NEWOBJ => FIELD_INT3D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_INT3D_CLONE - - FUNCTION FIELD_INT3D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT3D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_INT3D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_INT3D_CLONE_WRAPPER - - FUNCTION FIELD_INT3D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT3D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_INT3D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_INT3D_CLONE_OWNER - - - SUBROUTINE FIELD_INT3D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT3D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_INT3D_FINAL - - SUBROUTINE FIELD_INT3D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT3D_WRAPPER) :: SELF - INTEGER(KIND=JPIM), POINTER :: PTR(:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_INT3D_FINAL - END SUBROUTINE FIELD_INT3D_WRAPPER_FINAL - - SUBROUTINE FIELD_INT3D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT3D_WRAPPER_PACKED) :: SELF - INTEGER(KIND=JPIM), POINTER :: PTR(:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_INT3D_FINAL - END SUBROUTINE FIELD_INT3D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_INT3D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT3D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_INT3D_FINAL - END SUBROUTINE FIELD_INT3D_OWNER_FINAL - - SUBROUTINE FIELD_INT3D_ENSURE_HOST(SELF) - CLASS(FIELD_INT3D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_INT3D_ENSURE_HOST - - SUBROUTINE FIELD_INT3D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_INT3D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(3) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => SELF%PTR (:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_INT3D_GET_HOST_DATA - - SUBROUTINE FIELD_INT3D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_INT3D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_INT3D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_INT3D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_INT3D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_INT3D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_INT3D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_INT3D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_INT3D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_INT3D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(3) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => SELF%DEVPTR(:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_INT3D_GET_DEVICE_DATA - - SUBROUTINE FIELD_INT3D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_INT3D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_INT3D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_INT3D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_INT3D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_INT3D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_INT3D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_INT3D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_INT3D_COPY (SELF, KDIR) - CLASS(FIELD_INT3D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_INT3D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (3) - CALL COPY_DIM3_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2, J3 - - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2, J3), HST (J1, J2, J3), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2, J3), DEV (J1, J2, J3), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2, J3 - - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2, J3)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2, J3), HST (LBOUND(HST, 1), J2, J3), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2, J3), DEV (LBOUND(HST, 1), J2, J3), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J3 - - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - ISIZE = KIND (HST) * SIZE (HST (:, :, J3)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3), HST (LBOUND(HST, 1), LBOUND(HST, 2), J3), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), J3), DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM3_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3)), HST (LBOUND(HST, 1), LBOUND(HST, 2),& - & LBOUND(HST, 3)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3)), DEV (LBOUND(HST, 1), LBOUND(HST, 2),& - & LBOUND(HST, 3)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_INT3D_COPY - - - FUNCTION FIELD_INT4D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(3) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - - CLASS(FIELD_INT4D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(4) - INTEGER(KIND=JPIM) :: UBOUNDS(4) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = SHAPE(2) - UBOUNDS(3) = SHAPE(3) - UBOUNDS(4) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_INT4D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_INT4D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - - CLASS(FIELD_INT4D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_INT4D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_INT4D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_INT4D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_INT4D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_INT4D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_INT4D_WRAPPER), INTENT(INOUT) :: SELF - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 4)) THEN - CALL ABOR1 ('FIELD_INT4D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_INT4D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_INT4D_WRAP - - SUBROUTINE FIELD_INT4D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_INT4D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 5 .AND. BUFFER_RANK /= 4)THEN - CALL ABOR1 ('FIELD_INT4D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 5) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => DATA(:,:,:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => DATA(:,:,:,IDX,:) - ELSE - SELF%PTR => DATA(:,:,:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_INT4D_WRAP_PACKED - - SUBROUTINE FIELD_INT4D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_INT4D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(4) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(4) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(4) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(4) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(4) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 4 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(4) = 1 - REAL_UBOUNDS(4) = UBOUNDS(4) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2),REAL_LBOUNDS(3):REAL_UBOUNDS(3),REAL_LBOUNDS(& - &4):REAL_UBOUNDS(4))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_INT4D_ALLOCATE - - FUNCTION FIELD_INT4D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_INT4D) :: SELF - INTEGER(KIND=JPIM), POINTER :: VIEW_PTR(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(4) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):,LBOUNDS(2):,LBOUNDS(3):) => SELF%PTR(:,:,:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:,:,:) = 0.0_JPIM - END IF - END FUNCTION FIELD_INT4D_GET_VIEW - - FUNCTION FIELD_INT4D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT4D), INTENT(INOUT) :: SELF - CLASS(FIELD_INT4D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_INT4D_OWNER) - NEWOBJ => FIELD_INT4D_CLONE_OWNER(SELF) - TYPE IS(FIELD_INT4D_WRAPPER) - NEWOBJ => FIELD_INT4D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_INT4D_CLONE - - FUNCTION FIELD_INT4D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT4D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_INT4D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_INT4D_CLONE_WRAPPER - - FUNCTION FIELD_INT4D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT4D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_INT4D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_INT4D_CLONE_OWNER - - - SUBROUTINE FIELD_INT4D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT4D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_INT4D_FINAL - - SUBROUTINE FIELD_INT4D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT4D_WRAPPER) :: SELF - INTEGER(KIND=JPIM), POINTER :: PTR(:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_INT4D_FINAL - END SUBROUTINE FIELD_INT4D_WRAPPER_FINAL - - SUBROUTINE FIELD_INT4D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT4D_WRAPPER_PACKED) :: SELF - INTEGER(KIND=JPIM), POINTER :: PTR(:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_INT4D_FINAL - END SUBROUTINE FIELD_INT4D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_INT4D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT4D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_INT4D_FINAL - END SUBROUTINE FIELD_INT4D_OWNER_FINAL - - SUBROUTINE FIELD_INT4D_ENSURE_HOST(SELF) - CLASS(FIELD_INT4D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_INT4D_ENSURE_HOST - - SUBROUTINE FIELD_INT4D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_INT4D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(4) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => SELF%PTR (:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_INT4D_GET_HOST_DATA - - SUBROUTINE FIELD_INT4D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_INT4D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_INT4D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_INT4D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_INT4D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_INT4D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_INT4D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_INT4D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_INT4D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_INT4D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(4) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => SELF%DEVPTR(:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_INT4D_GET_DEVICE_DATA - - SUBROUTINE FIELD_INT4D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_INT4D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_INT4D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_INT4D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_INT4D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_INT4D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_INT4D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_INT4D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_INT4D_COPY (SELF, KDIR) - CLASS(FIELD_INT4D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_INT4D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (3) - CALL COPY_DIM3_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (4) - CALL COPY_DIM4_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2, J3, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2, J3, J4), HST (J1, J2, J3, J4), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2, J3, J4), DEV (J1, J2, J3, J4), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2, J3, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2, J3, J4)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2, J3, J4), HST (LBOUND(HST, 1), J2, J3, J4), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2, J3, J4), DEV (LBOUND(HST, 1), J2, J3, J4), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J3, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - ISIZE = KIND (HST) * SIZE (HST (:, :, J3, J4)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4), HST (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4),& - & ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4), DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4),& - & ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM3_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - ISIZE = KIND (HST) * SIZE (HST (:, :, :, J4)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4), HST (LBOUND(HST, 1), LBOUND(HST, 2),& - & LBOUND(HST, 3), J4), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4), DEV (LBOUND(HST, 1), LBOUND(HST,& - & 2), LBOUND(HST, 3), J4), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM4_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :, :, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), HST (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), DEV (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_INT4D_COPY - - - FUNCTION FIELD_INT5D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(4) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - - CLASS(FIELD_INT5D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(5) - INTEGER(KIND=JPIM) :: UBOUNDS(5) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = SHAPE(2) - UBOUNDS(3) = SHAPE(3) - UBOUNDS(4) = SHAPE(4) - UBOUNDS(5) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_INT5D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_INT5D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - - CLASS(FIELD_INT5D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_INT5D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_INT5D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_INT5D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_INT5D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_INT5D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_INT5D_WRAPPER), INTENT(INOUT) :: SELF - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 5)) THEN - CALL ABOR1 ('FIELD_INT5D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_INT5D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_INT5D_WRAP - - SUBROUTINE FIELD_INT5D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_INT5D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - INTEGER(KIND=JPIM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 6 .AND. BUFFER_RANK /= 5)THEN - CALL ABOR1 ('FIELD_INT5D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 6) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => DATA(:,:,:,:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,:,:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => DATA(:,:,:,:,IDX,:) - ELSE - SELF%PTR => DATA(:,:,:,:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_INT5D_WRAP_PACKED - - SUBROUTINE FIELD_INT5D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_INT5D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(5) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(5) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(5) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(5) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(5) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 5 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(5) = 1 - REAL_UBOUNDS(5) = UBOUNDS(5) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2),REAL_LBOUNDS(3):REAL_UBOUNDS(3),REAL_LBOUNDS(& - &4):REAL_UBOUNDS(4),REAL_LBOUNDS(5):REAL_UBOUNDS(5))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_INT5D_ALLOCATE - - FUNCTION FIELD_INT5D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_INT5D) :: SELF - INTEGER(KIND=JPIM), POINTER :: VIEW_PTR(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(5) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):,LBOUNDS(2):,LBOUNDS(3):,LBOUNDS(4):) => SELF%PTR(:,:,:,:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:,:,:,:) = 0.0_JPIM - END IF - END FUNCTION FIELD_INT5D_GET_VIEW - - FUNCTION FIELD_INT5D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT5D), INTENT(INOUT) :: SELF - CLASS(FIELD_INT5D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_INT5D_OWNER) - NEWOBJ => FIELD_INT5D_CLONE_OWNER(SELF) - TYPE IS(FIELD_INT5D_WRAPPER) - NEWOBJ => FIELD_INT5D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_INT5D_CLONE - - FUNCTION FIELD_INT5D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT5D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_INT5D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_INT5D_CLONE_WRAPPER - - FUNCTION FIELD_INT5D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_INT5D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_INT5D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_INT5D_CLONE_OWNER - - - SUBROUTINE FIELD_INT5D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT5D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_INT5D_FINAL - - SUBROUTINE FIELD_INT5D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT5D_WRAPPER) :: SELF - INTEGER(KIND=JPIM), POINTER :: PTR(:,:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_INT5D_FINAL - END SUBROUTINE FIELD_INT5D_WRAPPER_FINAL - - SUBROUTINE FIELD_INT5D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT5D_WRAPPER_PACKED) :: SELF - INTEGER(KIND=JPIM), POINTER :: PTR(:,:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_INT5D_FINAL - END SUBROUTINE FIELD_INT5D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_INT5D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_INT5D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_INT5D_FINAL - END SUBROUTINE FIELD_INT5D_OWNER_FINAL - - SUBROUTINE FIELD_INT5D_ENSURE_HOST(SELF) - CLASS(FIELD_INT5D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_INT5D_ENSURE_HOST - - SUBROUTINE FIELD_INT5D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_INT5D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(5) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => SELF%PTR (:,:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_INT5D_GET_HOST_DATA - - SUBROUTINE FIELD_INT5D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_INT5D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_INT5D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_INT5D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_INT5D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_INT5D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_INT5D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_INT5D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_INT5D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_INT5D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(5) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => SELF%DEVPTR(:,:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_INT5D_GET_DEVICE_DATA - - SUBROUTINE FIELD_INT5D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_INT5D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_INT5D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_INT5D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_INT5D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_INT5D), INTENT (INOUT) :: SELF - INTEGER(KIND=JPIM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_INT5D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_INT5D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_INT5D_COPY (SELF, KDIR) - CLASS(FIELD_INT5D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_INT5D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (3) - CALL COPY_DIM3_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (4) - CALL COPY_DIM4_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (5) - CALL COPY_DIM5_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2, J3, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2, J3, J4, J5), HST (J1, J2, J3, J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2, J3, J4, J5), DEV (J1, J2, J3, J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2, J3, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2, J3, J4, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2, J3, J4, J5), HST (LBOUND(HST, 1), J2, J3, J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2, J3, J4, J5), DEV (LBOUND(HST, 1), J2, J3, J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J3, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - ISIZE = KIND (HST) * SIZE (HST (:, :, J3, J4, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4, J5), HST (LBOUND(HST, 1), LBOUND(HST, 2), J3,& - & J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4, J5), DEV (LBOUND(HST, 1), LBOUND(HST, 2),& - & J3, J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM3_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - ISIZE = KIND (HST) * SIZE (HST (:, :, :, J4, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), HST (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), DEV (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM4_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - ISIZE = KIND (HST) * SIZE (HST (:, :, :, :, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), HST (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), DEV (LBOUND(HST,& - & 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM5_CONTIGUOUS (HST, DEV, KDIR) - INTEGER(KIND=JPIM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :, :, :, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), HST& - & (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), DEV& - & (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_INT5D_COPY - - - FUNCTION FIELD_LOG2D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(1) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - - CLASS(FIELD_LOG2D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(2) - INTEGER(KIND=JPIM) :: UBOUNDS(2) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_LOG2D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_LOG2D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - - CLASS(FIELD_LOG2D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_LOG2D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_LOG2D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_LOG2D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_LOG2D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_LOG2D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_LOG2D_WRAPPER), INTENT(INOUT) :: SELF - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 2)) THEN - CALL ABOR1 ('FIELD_LOG2D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_LOG2D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_LOG2D_WRAP - - SUBROUTINE FIELD_LOG2D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_LOG2D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(2) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 3 .AND. BUFFER_RANK /= 2)THEN - CALL ABOR1 ('FIELD_LOG2D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 3) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):) => DATA(:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):) => DATA(:,IDX,:) - ELSE - SELF%PTR => DATA(:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_LOG2D_WRAP_PACKED - - SUBROUTINE FIELD_LOG2D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_LOG2D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(2) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(2) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(2) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(2) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(2) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 2 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(2) = 1 - REAL_UBOUNDS(2) = UBOUNDS(2) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_LOG2D_ALLOCATE - - FUNCTION FIELD_LOG2D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_LOG2D) :: SELF - LOGICAL(KIND=JPLM), POINTER :: VIEW_PTR(:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(2) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):) => SELF%PTR(:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:) = .FALSE. - END IF - END FUNCTION FIELD_LOG2D_GET_VIEW - - FUNCTION FIELD_LOG2D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG2D), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG2D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_LOG2D_OWNER) - NEWOBJ => FIELD_LOG2D_CLONE_OWNER(SELF) - TYPE IS(FIELD_LOG2D_WRAPPER) - NEWOBJ => FIELD_LOG2D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_LOG2D_CLONE - - FUNCTION FIELD_LOG2D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG2D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG2D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_LOG2D_CLONE_WRAPPER - - FUNCTION FIELD_LOG2D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG2D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG2D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_LOG2D_CLONE_OWNER - - - SUBROUTINE FIELD_LOG2D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG2D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_LOG2D_FINAL - - SUBROUTINE FIELD_LOG2D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG2D_WRAPPER) :: SELF - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_LOG2D_FINAL - END SUBROUTINE FIELD_LOG2D_WRAPPER_FINAL - - SUBROUTINE FIELD_LOG2D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG2D_WRAPPER_PACKED) :: SELF - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_LOG2D_FINAL - END SUBROUTINE FIELD_LOG2D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_LOG2D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG2D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_LOG2D_FINAL - END SUBROUTINE FIELD_LOG2D_OWNER_FINAL - - SUBROUTINE FIELD_LOG2D_ENSURE_HOST(SELF) - CLASS(FIELD_LOG2D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_LOG2D_ENSURE_HOST - - SUBROUTINE FIELD_LOG2D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_LOG2D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(2) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):) => SELF%PTR (:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_LOG2D_GET_HOST_DATA - - SUBROUTINE FIELD_LOG2D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_LOG2D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_LOG2D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_LOG2D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_LOG2D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_LOG2D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_LOG2D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_LOG2D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_LOG2D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_LOG2D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(2) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):) => SELF%DEVPTR(:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_LOG2D_GET_DEVICE_DATA - - SUBROUTINE FIELD_LOG2D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_LOG2D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_LOG2D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_LOG2D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_LOG2D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_LOG2D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:) - - CALL FIELD_LOG2D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_LOG2D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_LOG2D_COPY (SELF, KDIR) - CLASS(FIELD_LOG2D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_LOG2D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:), DEV (:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2 - - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2), HST (J1, J2), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2), DEV (J1, J2), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:), DEV (:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2 - - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2), HST (LBOUND(HST, 1), J2), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2), DEV (LBOUND(HST, 1), J2), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:), DEV (:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2)), HST (LBOUND(HST, 1), LBOUND(HST, 2)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2)), DEV (LBOUND(HST, 1), LBOUND(HST, 2)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_LOG2D_COPY - - - FUNCTION FIELD_LOG3D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(2) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - - CLASS(FIELD_LOG3D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(3) - INTEGER(KIND=JPIM) :: UBOUNDS(3) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = SHAPE(2) - UBOUNDS(3) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_LOG3D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_LOG3D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - - CLASS(FIELD_LOG3D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_LOG3D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_LOG3D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_LOG3D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_LOG3D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_LOG3D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_LOG3D_WRAPPER), INTENT(INOUT) :: SELF - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 3)) THEN - CALL ABOR1 ('FIELD_LOG3D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_LOG3D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_LOG3D_WRAP - - SUBROUTINE FIELD_LOG3D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_LOG3D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(3) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 4 .AND. BUFFER_RANK /= 3)THEN - CALL ABOR1 ('FIELD_LOG3D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 4) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => DATA(:,:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => DATA(:,:,IDX,:) - ELSE - SELF%PTR => DATA(:,:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_LOG3D_WRAP_PACKED - - SUBROUTINE FIELD_LOG3D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_LOG3D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(3) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(3) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(3) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(3) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(3) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 3 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(3) = 1 - REAL_UBOUNDS(3) = UBOUNDS(3) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2),REAL_LBOUNDS(3):REAL_UBOUNDS(3))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_LOG3D_ALLOCATE - - FUNCTION FIELD_LOG3D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_LOG3D) :: SELF - LOGICAL(KIND=JPLM), POINTER :: VIEW_PTR(:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(3) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):,LBOUNDS(2):) => SELF%PTR(:,:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:,:) = .FALSE. - END IF - END FUNCTION FIELD_LOG3D_GET_VIEW - - FUNCTION FIELD_LOG3D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG3D), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG3D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_LOG3D_OWNER) - NEWOBJ => FIELD_LOG3D_CLONE_OWNER(SELF) - TYPE IS(FIELD_LOG3D_WRAPPER) - NEWOBJ => FIELD_LOG3D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_LOG3D_CLONE - - FUNCTION FIELD_LOG3D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG3D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG3D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_LOG3D_CLONE_WRAPPER - - FUNCTION FIELD_LOG3D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG3D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG3D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_LOG3D_CLONE_OWNER - - - SUBROUTINE FIELD_LOG3D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG3D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_LOG3D_FINAL - - SUBROUTINE FIELD_LOG3D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG3D_WRAPPER) :: SELF - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_LOG3D_FINAL - END SUBROUTINE FIELD_LOG3D_WRAPPER_FINAL - - SUBROUTINE FIELD_LOG3D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG3D_WRAPPER_PACKED) :: SELF - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_LOG3D_FINAL - END SUBROUTINE FIELD_LOG3D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_LOG3D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG3D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_LOG3D_FINAL - END SUBROUTINE FIELD_LOG3D_OWNER_FINAL - - SUBROUTINE FIELD_LOG3D_ENSURE_HOST(SELF) - CLASS(FIELD_LOG3D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_LOG3D_ENSURE_HOST - - SUBROUTINE FIELD_LOG3D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_LOG3D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(3) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => SELF%PTR (:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_LOG3D_GET_HOST_DATA - - SUBROUTINE FIELD_LOG3D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_LOG3D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_LOG3D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_LOG3D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_LOG3D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_LOG3D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_LOG3D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_LOG3D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_LOG3D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_LOG3D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(3) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):) => SELF%DEVPTR(:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_LOG3D_GET_DEVICE_DATA - - SUBROUTINE FIELD_LOG3D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_LOG3D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_LOG3D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_LOG3D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_LOG3D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_LOG3D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:) - - CALL FIELD_LOG3D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_LOG3D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_LOG3D_COPY (SELF, KDIR) - CLASS(FIELD_LOG3D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_LOG3D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (3) - CALL COPY_DIM3_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2, J3 - - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2, J3), HST (J1, J2, J3), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2, J3), DEV (J1, J2, J3), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2, J3 - - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2, J3)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2, J3), HST (LBOUND(HST, 1), J2, J3), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2, J3), DEV (LBOUND(HST, 1), J2, J3), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J3 - - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - ISIZE = KIND (HST) * SIZE (HST (:, :, J3)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3), HST (LBOUND(HST, 1), LBOUND(HST, 2), J3), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), J3), DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM3_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:), DEV (:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3)), HST (LBOUND(HST, 1), LBOUND(HST, 2),& - & LBOUND(HST, 3)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3)), DEV (LBOUND(HST, 1), LBOUND(HST, 2),& - & LBOUND(HST, 3)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_LOG3D_COPY - - - FUNCTION FIELD_LOG4D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(3) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - - CLASS(FIELD_LOG4D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(4) - INTEGER(KIND=JPIM) :: UBOUNDS(4) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = SHAPE(2) - UBOUNDS(3) = SHAPE(3) - UBOUNDS(4) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_LOG4D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_LOG4D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - - CLASS(FIELD_LOG4D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_LOG4D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_LOG4D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_LOG4D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_LOG4D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_LOG4D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_LOG4D_WRAPPER), INTENT(INOUT) :: SELF - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 4)) THEN - CALL ABOR1 ('FIELD_LOG4D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_LOG4D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_LOG4D_WRAP - - SUBROUTINE FIELD_LOG4D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_LOG4D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(4) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 5 .AND. BUFFER_RANK /= 4)THEN - CALL ABOR1 ('FIELD_LOG4D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 5) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => DATA(:,:,:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => DATA(:,:,:,IDX,:) - ELSE - SELF%PTR => DATA(:,:,:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_LOG4D_WRAP_PACKED - - SUBROUTINE FIELD_LOG4D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_LOG4D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(4) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(4) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(4) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(4) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(4) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 4 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(4) = 1 - REAL_UBOUNDS(4) = UBOUNDS(4) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2),REAL_LBOUNDS(3):REAL_UBOUNDS(3),REAL_LBOUNDS(& - &4):REAL_UBOUNDS(4))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_LOG4D_ALLOCATE - - FUNCTION FIELD_LOG4D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_LOG4D) :: SELF - LOGICAL(KIND=JPLM), POINTER :: VIEW_PTR(:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(4) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):,LBOUNDS(2):,LBOUNDS(3):) => SELF%PTR(:,:,:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:,:,:) = .FALSE. - END IF - END FUNCTION FIELD_LOG4D_GET_VIEW - - FUNCTION FIELD_LOG4D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG4D), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG4D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_LOG4D_OWNER) - NEWOBJ => FIELD_LOG4D_CLONE_OWNER(SELF) - TYPE IS(FIELD_LOG4D_WRAPPER) - NEWOBJ => FIELD_LOG4D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_LOG4D_CLONE - - FUNCTION FIELD_LOG4D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG4D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG4D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_LOG4D_CLONE_WRAPPER - - FUNCTION FIELD_LOG4D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG4D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG4D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_LOG4D_CLONE_OWNER - - - SUBROUTINE FIELD_LOG4D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG4D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_LOG4D_FINAL - - SUBROUTINE FIELD_LOG4D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG4D_WRAPPER) :: SELF - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_LOG4D_FINAL - END SUBROUTINE FIELD_LOG4D_WRAPPER_FINAL - - SUBROUTINE FIELD_LOG4D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG4D_WRAPPER_PACKED) :: SELF - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_LOG4D_FINAL - END SUBROUTINE FIELD_LOG4D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_LOG4D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG4D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_LOG4D_FINAL - END SUBROUTINE FIELD_LOG4D_OWNER_FINAL - - SUBROUTINE FIELD_LOG4D_ENSURE_HOST(SELF) - CLASS(FIELD_LOG4D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_LOG4D_ENSURE_HOST - - SUBROUTINE FIELD_LOG4D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_LOG4D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(4) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => SELF%PTR (:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_LOG4D_GET_HOST_DATA - - SUBROUTINE FIELD_LOG4D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_LOG4D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_LOG4D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_LOG4D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_LOG4D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_LOG4D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_LOG4D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_LOG4D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_LOG4D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_LOG4D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(4) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):) => SELF%DEVPTR(:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_LOG4D_GET_DEVICE_DATA - - SUBROUTINE FIELD_LOG4D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_LOG4D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_LOG4D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_LOG4D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_LOG4D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_LOG4D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:) - - CALL FIELD_LOG4D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_LOG4D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_LOG4D_COPY (SELF, KDIR) - CLASS(FIELD_LOG4D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_LOG4D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (3) - CALL COPY_DIM3_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (4) - CALL COPY_DIM4_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2, J3, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2, J3, J4), HST (J1, J2, J3, J4), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2, J3, J4), DEV (J1, J2, J3, J4), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2, J3, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2, J3, J4)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2, J3, J4), HST (LBOUND(HST, 1), J2, J3, J4), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2, J3, J4), DEV (LBOUND(HST, 1), J2, J3, J4), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J3, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - ISIZE = KIND (HST) * SIZE (HST (:, :, J3, J4)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4), HST (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4),& - & ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4), DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4),& - & ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM3_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J4 - - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - ISIZE = KIND (HST) * SIZE (HST (:, :, :, J4)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4), HST (LBOUND(HST, 1), LBOUND(HST, 2),& - & LBOUND(HST, 3), J4), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4), DEV (LBOUND(HST, 1), LBOUND(HST,& - & 2), LBOUND(HST, 3), J4), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM4_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:,:), DEV (:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :, :, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), HST (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), DEV (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_LOG4D_COPY - - - FUNCTION FIELD_LOG5D_OWNER_CONSTRUCTOR(SHAPE, NBLOCKS, PERSISTENT, LBOUNDS) RESULT(FIELD_PTR) - INTEGER(KIND=JPIM), INTENT(IN) :: SHAPE(4) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: NBLOCKS - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - - CLASS(FIELD_LOG5D_OWNER), POINTER :: FIELD_PTR - INTEGER(KIND=JPIM) :: LLBOUNDS(5) - INTEGER(KIND=JPIM) :: UBOUNDS(5) - - IF(PRESENT(LBOUNDS))THEN - LLBOUNDS = LBOUNDS - ELSE - LLBOUNDS = 1_JPIM - ENDIF - - UBOUNDS(1) = SHAPE(1) - UBOUNDS(2) = SHAPE(2) - UBOUNDS(3) = SHAPE(3) - UBOUNDS(4) = SHAPE(4) - UBOUNDS(5) = NBLOCKS - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(LLBOUNDS, UBOUNDS, PERSISTENT=PERSISTENT) - - END FUNCTION FIELD_LOG5D_OWNER_CONSTRUCTOR - - FUNCTION FIELD_LOG5D_WRAPPER_CONSTRUCTOR(DATA, LBOUNDS) RESULT(FIELD_PTR) - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - - CLASS(FIELD_LOG5D_WRAPPER), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, LBOUNDS=LBOUNDS) - - END FUNCTION FIELD_LOG5D_WRAPPER_CONSTRUCTOR - - FUNCTION FIELD_LOG5D_WRAPPER_PACKED_CONSTRUCTOR(DATA, IDX, LBOUNDS, BUFFER_RANK) RESULT(FIELD_PTR) - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - - CLASS(FIELD_LOG5D_WRAPPER_PACKED), POINTER :: FIELD_PTR - - ALLOCATE(FIELD_PTR) - CALL FIELD_PTR%INIT(DATA=DATA, IDX=IDX, LBOUNDS=LBOUNDS, BUFFER_RANK=BUFFER_RANK) - - END FUNCTION FIELD_LOG5D_WRAPPER_PACKED_CONSTRUCTOR - - SUBROUTINE FIELD_LOG5D_WRAP(SELF, DATA, PERSISTENT, LBOUNDS) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_LOG5D_WRAPPER), INTENT(INOUT) :: SELF - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - LOGICAL :: LLPERSISTENT - - LLPERSISTENT = .TRUE. - IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT - - IF (PRESENT(LBOUNDS)) THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => DATA - ELSE - SELF%PTR => DATA - ENDIF - SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - SELF%ISTATUS = NHSTFRESH - - IF (.NOT. LLPERSISTENT) THEN - IF (OML_MAX_THREADS() /= SIZE (DATA, 5)) THEN - CALL ABOR1 ('FIELD_LOG5D_WRAP: DIMENSION MISMATCH') - ENDIF - ENDIF - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_LOG5D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - END SUBROUTINE FIELD_LOG5D_WRAP - - SUBROUTINE FIELD_LOG5D_WRAP_PACKED(SELF, DATA, IDX, LBOUNDS, BUFFER_RANK) - ! Create FIELD object by wrapping existing data - CLASS(FIELD_LOG5D_WRAPPER_PACKED), INTENT(INOUT) :: SELF - LOGICAL(KIND=JPLM), TARGET, INTENT(IN) :: DATA(:,:,:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: IDX - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(5) - INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: BUFFER_RANK - LOGICAL :: LLPERSISTENT - - SELF%CONTIG_PACKED = .FALSE. - IF(PRESENT(BUFFER_RANK))THEN - IF(BUFFER_RANK /= 6 .AND. BUFFER_RANK /= 5)THEN - CALL ABOR1 ('FIELD_LOG5D_WRAP_PACKED: INCORRECT BUFFER_RANK') - ENDIF - IF(BUFFER_RANK == 6) SELF%CONTIG_PACKED = .TRUE. - ENDIF - - - IF(SELF%CONTIG_PACKED)THEN - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => DATA(:,:,:,:,:,IDX) - ELSE - SELF%PTR => DATA(:,:,:,:,:,IDX) - ENDIF - ELSE - IF(PRESENT(LBOUNDS))THEN - SELF%PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => DATA(:,:,:,:,IDX,:) - ELSE - SELF%PTR => DATA(:,:,:,:,IDX,:) - ENDIF - ENDIF - SELF%THREAD_BUFFER = .FALSE. - SELF%ISTATUS = NHSTFRESH - - SELF%BASE_PTR => DATA - SELF%FIDX = IDX - - END SUBROUTINE FIELD_LOG5D_WRAP_PACKED - - SUBROUTINE FIELD_LOG5D_ALLOCATE (SELF, LBOUNDS, UBOUNDS, PERSISTENT) - ! Create FIELD object by explicitly allocating new data - CLASS(FIELD_LOG5D_OWNER) :: SELF - INTEGER(KIND=JPIM), INTENT(IN) :: LBOUNDS(5) - INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(5) - LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT - INTEGER(KIND=JPIM) :: REAL_LBOUNDS(5) - INTEGER(KIND=JPIM) :: REAL_UBOUNDS(5) - INTEGER(KIND=JPIM) :: ISTAT, ARRSIZE - - REAL_LBOUNDS=LBOUNDS - REAL_UBOUNDS=UBOUNDS - REAL_UBOUNDS(5) = OML_MAX_THREADS() - - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. - - SELF%LAST_CONTIGUOUS_DIMENSION = 5 - - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - REAL_LBOUNDS(5) = 1 - REAL_UBOUNDS(5) = UBOUNDS(5) - END IF - END IF - - ALLOCATE(SELF%PTR(REAL_LBOUNDS(1):REAL_UBOUNDS(1),REAL_LBOUNDS(2):REAL_UBOUNDS(2),REAL_LBOUNDS(3):REAL_UBOUNDS(3),REAL_LBOUNDS(& - &4):REAL_UBOUNDS(4),REAL_LBOUNDS(5):REAL_UBOUNDS(5))) - - SELF%ISTATUS = NHSTFRESH - END SUBROUTINE FIELD_LOG5D_ALLOCATE - - FUNCTION FIELD_LOG5D_GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR) - CLASS(FIELD_LOG5D) :: SELF - LOGICAL(KIND=JPLM), POINTER :: VIEW_PTR(:,:,:,:) - INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX - LOGICAL, OPTIONAL, INTENT(IN) :: ZERO - INTEGER(KIND=JPIM) :: IDX - INTEGER(KIND=JPIM) :: LBOUNDS(5) - - IDX = BLOCK_INDEX - IF (SELF%THREAD_BUFFER) IDX = OML_MY_THREAD() - - LBOUNDS=LBOUND(SELF%PTR) - VIEW_PTR(LBOUNDS(1):,LBOUNDS(2):,LBOUNDS(3):,LBOUNDS(4):) => SELF%PTR(:,:,:,:,IDX) - - IF (PRESENT(ZERO)) THEN - IF (ZERO) VIEW_PTR(:,:,:,:) = .FALSE. - END IF - END FUNCTION FIELD_LOG5D_GET_VIEW - - FUNCTION FIELD_LOG5D_CLONE(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG5D), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG5D), POINTER :: NEWOBJ - - SELECT TYPE(SELF) - TYPE IS(FIELD_LOG5D_OWNER) - NEWOBJ => FIELD_LOG5D_CLONE_OWNER(SELF) - TYPE IS(FIELD_LOG5D_WRAPPER) - NEWOBJ => FIELD_LOG5D_CLONE_WRAPPER(SELF) - CLASS DEFAULT - PRINT *, "MUST NEVER ARRIVE HERE CLONE" - ERROR STOP - END SELECT - - END FUNCTION FIELD_LOG5D_CLONE - - FUNCTION FIELD_LOG5D_CLONE_WRAPPER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG5D_WRAPPER), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG5D_WRAPPER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(DATA=SELF%PTR, PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR)) - END FUNCTION FIELD_LOG5D_CLONE_WRAPPER - - FUNCTION FIELD_LOG5D_CLONE_OWNER(SELF) RESULT(NEWOBJ) - CLASS(FIELD_LOG5D_OWNER), INTENT(INOUT) :: SELF - CLASS(FIELD_LOG5D_OWNER), POINTER :: NEWOBJ - - ALLOCATE(NEWOBJ) - CALL NEWOBJ%INIT(PERSISTENT=.NOT. SELF%THREAD_BUFFER, LBOUNDS=LBOUND(SELF%PTR), UBOUNDS=UBOUND(SELF%PTR)) - END FUNCTION FIELD_LOG5D_CLONE_OWNER - - - SUBROUTINE FIELD_LOG5D_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG5D) :: SELF - - NULLIFY(SELF%DEVPTR) - NULLIFY(SELF%PTR) - END SUBROUTINE FIELD_LOG5D_FINAL - - SUBROUTINE FIELD_LOG5D_WRAPPER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG5D_WRAPPER) :: SELF - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_LOG5D_FINAL - END SUBROUTINE FIELD_LOG5D_WRAPPER_FINAL - - SUBROUTINE FIELD_LOG5D_WRAPPER_PACKED_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG5D_WRAPPER_PACKED) :: SELF - LOGICAL(KIND=JPLM), POINTER :: PTR(:,:,:,:,:) - CALL SELF%GET_HOST_DATA_RDONLY(PTR) - CALL SELF%FIELD_LOG5D_FINAL - END SUBROUTINE FIELD_LOG5D_WRAPPER_PACKED_FINAL - - SUBROUTINE FIELD_LOG5D_OWNER_FINAL(SELF) - ! Finalizes field and deallocates owned data - CLASS(FIELD_LOG5D_OWNER) :: SELF - IF(ASSOCIATED(SELF%PTR))THEN - DEALLOCATE(SELF%PTR) - ENDIF - CALL SELF%FIELD_LOG5D_FINAL - END SUBROUTINE FIELD_LOG5D_OWNER_FINAL - - SUBROUTINE FIELD_LOG5D_ENSURE_HOST(SELF) - CLASS(FIELD_LOG5D), INTENT (INOUT) :: SELF - - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - - ENDIF - - END SUBROUTINE FIELD_LOG5D_ENSURE_HOST - - SUBROUTINE FIELD_LOG5D_GET_HOST_DATA (SELF, MODE, PTR) - CLASS(FIELD_LOG5D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(5) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NHSTFRESH) == 0) THEN -#ifdef _OPENACC - CALL SELF%COPY (ND2H) -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NHSTFRESH) - ENDIF - PTR (LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => SELF%PTR (:,:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NDEVFRESH)) - ENDIF - - END SUBROUTINE FIELD_LOG5D_GET_HOST_DATA - - SUBROUTINE FIELD_LOG5D_GET_HOST_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_LOG5D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_LOG5D_GET_HOST_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_LOG5D_GET_HOST_DATA_RDONLY - - SUBROUTINE FIELD_LOG5D_GET_HOST_DATA_RDWR (SELF, PTR) - CLASS(FIELD_LOG5D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_LOG5D_GET_HOST_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_LOG5D_GET_HOST_DATA_RDWR - - SUBROUTINE FIELD_LOG5D_GET_DEVICE_DATA (SELF, MODE, PTR) - CLASS(FIELD_LOG5D), INTENT (INOUT) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: MODE - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - INTEGER(KIND=JPIM) :: LBOUNDS(5) - - LBOUNDS=LBOUND(SELF%PTR) - IF (IAND (SELF%ISTATUS, NDEVFRESH) == 0) THEN -#ifdef _OPENACC - IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN - ALLOCATE (SELF%DEVPTR, MOLD=SELF%PTR) - !$acc enter data create (SELF%DEVPTR) - ENDIF - CALL SELF%COPY (NH2D) -#else - SELF%DEVPTR => SELF%PTR -#endif /*_OPENACC*/ - SELF%ISTATUS = IOR (SELF%ISTATUS, NDEVFRESH) - ENDIF - PTR(LBOUNDS(1):, LBOUNDS(2):, LBOUNDS(3):, LBOUNDS(4):, LBOUNDS(5):) => SELF%DEVPTR(:,:,:,:,:) - IF (IAND (MODE, NWR) /= 0) THEN - SELF%ISTATUS = IAND (SELF%ISTATUS, NOT (NHSTFRESH)) - ENDIF - - END SUBROUTINE FIELD_LOG5D_GET_DEVICE_DATA - - SUBROUTINE FIELD_LOG5D_GET_DEVICE_DATA_RDONLY (SELF, PTR) - CLASS(FIELD_LOG5D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_LOG5D_GET_DEVICE_DATA (SELF, NRD, PTR) - - END SUBROUTINE FIELD_LOG5D_GET_DEVICE_DATA_RDONLY - - SUBROUTINE FIELD_LOG5D_GET_DEVICE_DATA_RDWR (SELF, PTR) - CLASS(FIELD_LOG5D), INTENT (INOUT) :: SELF - LOGICAL(KIND=JPLM), POINTER, INTENT(INOUT) :: PTR(:,:,:,:,:) - - CALL FIELD_LOG5D_GET_DEVICE_DATA (SELF, IOR (NRD, NWR), PTR) - - END SUBROUTINE FIELD_LOG5D_GET_DEVICE_DATA_RDWR - - SUBROUTINE FIELD_LOG5D_COPY (SELF, KDIR) - CLASS(FIELD_LOG5D) :: SELF - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - REAL :: START, FINISH -#ifdef _OPENACC - - SELF%LAST_CONTIGUOUS_DIMENSION = FIELD_LOG5D_GET_LAST_CONTIGUOUS_DIMENSION (SELF%PTR) - - SELECT CASE (SELF%LAST_CONTIGUOUS_DIMENSION) - CASE (0) - CALL COPY_DIM0_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (1) - CALL COPY_DIM1_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (2) - CALL COPY_DIM2_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (3) - CALL COPY_DIM3_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (4) - CALL COPY_DIM4_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - CASE (5) - CALL COPY_DIM5_CONTIGUOUS (SELF%PTR, SELF%DEVPTR, KDIR) - END SELECT - - CONTAINS - - SUBROUTINE COPY_DIM0_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J1, J2, J3, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - DO J1 = LBOUND (HST, 1), UBOUND (HST, 1) - ISIZE = KIND (HST) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (J1, J2, J3, J4, J5), HST (J1, J2, J3, J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (J1, J2, J3, J4, J5), DEV (J1, J2, J3, J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM1_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J2, J3, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - DO J2 = LBOUND (HST, 2), UBOUND (HST, 2) - ISIZE = KIND (HST) * SIZE (HST (:, J2, J3, J4, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), J2, J3, J4, J5), HST (LBOUND(HST, 1), J2, J3, J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), J2, J3, J4, J5), DEV (LBOUND(HST, 1), J2, J3, J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM2_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J3, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - DO J3 = LBOUND (HST, 3), UBOUND (HST, 3) - ISIZE = KIND (HST) * SIZE (HST (:, :, J3, J4, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4, J5), HST (LBOUND(HST, 1), LBOUND(HST, 2), J3,& - & J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), J3, J4, J5), DEV (LBOUND(HST, 1), LBOUND(HST, 2),& - & J3, J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM3_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J4, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - DO J4 = LBOUND (HST, 4), UBOUND (HST, 4) - ISIZE = KIND (HST) * SIZE (HST (:, :, :, J4, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), HST (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), DEV (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), J4, J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM4_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J, J5 - - DO J5 = LBOUND (HST, 5), UBOUND (HST, 5) - ISIZE = KIND (HST) * SIZE (HST (:, :, :, :, J5)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), HST (LBOUND(HST, 1),& - & LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), DEV (LBOUND(HST,& - & 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), J5), ISIZE) - !$acc end host_data - ENDIF - ENDDO - END SUBROUTINE - - SUBROUTINE COPY_DIM5_CONTIGUOUS (HST, DEV, KDIR) - LOGICAL(KIND=JPLM), POINTER :: HST (:,:,:,:,:), DEV (:,:,:,:,:) - INTEGER (KIND=JPIM), INTENT (IN) :: KDIR - INTEGER (KIND=JPIM) :: ISIZE - INTEGER :: J - - ISIZE = KIND (HST) * SIZE (HST (:, :, :, :, :)) - IF (KDIR == NH2D) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_TO_DEVICE (DEV (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), HST& - & (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), ISIZE) - !$acc end host_data - ELSEIF (KDIR == ND2H) THEN - !$acc host_data use_device (DEV) - CALL ACC_MEMCPY_FROM_DEVICE (HST (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), DEV& - & (LBOUND(HST, 1), LBOUND(HST, 2), LBOUND(HST, 3), LBOUND(HST, 4), LBOUND(HST, 5)), ISIZE) - !$acc end host_data - ENDIF - END SUBROUTINE - -#endif /*_OPENACC*/ - END SUBROUTINE FIELD_LOG5D_COPY - - - - - - -! -! HELPERS -! - - INTEGER (KIND=JPIM) FUNCTION FIELD_2D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - REAL(KIND=JPRB), POINTER :: PTR (:,:) - INTEGER*8 :: ISTRIDE (2) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 2 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1)) - LOC (PTR (1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2)) - LOC (PTR (1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - END FUNCTION FIELD_2D_GET_LAST_CONTIGUOUS_DIMENSION - INTEGER (KIND=JPIM) FUNCTION FIELD_3D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - REAL(KIND=JPRB), POINTER :: PTR (:,:,:) - INTEGER*8 :: ISTRIDE (3) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 3 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1, 1)) - LOC (PTR (1, 1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2, 1)) - LOC (PTR (1, 1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - IF (LOC (PTR (1, 1, 2)) - LOC (PTR (1, 1, 1)) /= ISTRIDE (3)) THEN - RETURN - ENDIF - - JDIM = 3 - - END FUNCTION FIELD_3D_GET_LAST_CONTIGUOUS_DIMENSION - INTEGER (KIND=JPIM) FUNCTION FIELD_4D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - REAL(KIND=JPRB), POINTER :: PTR (:,:,:,:) - INTEGER*8 :: ISTRIDE (4) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 4 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1, 1, 1)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2, 1, 1)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - IF (LOC (PTR (1, 1, 2, 1)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (3)) THEN - RETURN - ENDIF - - JDIM = 3 - - IF (LOC (PTR (1, 1, 1, 2)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (4)) THEN - RETURN - ENDIF - - JDIM = 4 - - END FUNCTION FIELD_4D_GET_LAST_CONTIGUOUS_DIMENSION - INTEGER (KIND=JPIM) FUNCTION FIELD_5D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - REAL(KIND=JPRB), POINTER :: PTR (:,:,:,:,:) - INTEGER*8 :: ISTRIDE (5) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 5 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1, 1, 1, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2, 1, 1, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - IF (LOC (PTR (1, 1, 2, 1, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (3)) THEN - RETURN - ENDIF - - JDIM = 3 - - IF (LOC (PTR (1, 1, 1, 2, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (4)) THEN - RETURN - ENDIF - - JDIM = 4 - - IF (LOC (PTR (1, 1, 1, 1, 2)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (5)) THEN - RETURN - ENDIF - - JDIM = 5 - - END FUNCTION FIELD_5D_GET_LAST_CONTIGUOUS_DIMENSION - INTEGER (KIND=JPIM) FUNCTION FIELD_INT2D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - INTEGER(KIND=JPIM), POINTER :: PTR (:,:) - INTEGER*8 :: ISTRIDE (2) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 2 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1)) - LOC (PTR (1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2)) - LOC (PTR (1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - END FUNCTION FIELD_INT2D_GET_LAST_CONTIGUOUS_DIMENSION - INTEGER (KIND=JPIM) FUNCTION FIELD_INT3D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - INTEGER(KIND=JPIM), POINTER :: PTR (:,:,:) - INTEGER*8 :: ISTRIDE (3) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 3 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1, 1)) - LOC (PTR (1, 1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2, 1)) - LOC (PTR (1, 1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - IF (LOC (PTR (1, 1, 2)) - LOC (PTR (1, 1, 1)) /= ISTRIDE (3)) THEN - RETURN - ENDIF - - JDIM = 3 - - END FUNCTION FIELD_INT3D_GET_LAST_CONTIGUOUS_DIMENSION - INTEGER (KIND=JPIM) FUNCTION FIELD_INT4D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - INTEGER(KIND=JPIM), POINTER :: PTR (:,:,:,:) - INTEGER*8 :: ISTRIDE (4) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 4 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1, 1, 1)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2, 1, 1)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - IF (LOC (PTR (1, 1, 2, 1)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (3)) THEN - RETURN - ENDIF - - JDIM = 3 - - IF (LOC (PTR (1, 1, 1, 2)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (4)) THEN - RETURN - ENDIF - - JDIM = 4 - - END FUNCTION FIELD_INT4D_GET_LAST_CONTIGUOUS_DIMENSION - INTEGER (KIND=JPIM) FUNCTION FIELD_INT5D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - INTEGER(KIND=JPIM), POINTER :: PTR (:,:,:,:,:) - INTEGER*8 :: ISTRIDE (5) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 5 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1, 1, 1, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2, 1, 1, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - IF (LOC (PTR (1, 1, 2, 1, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (3)) THEN - RETURN - ENDIF - - JDIM = 3 - - IF (LOC (PTR (1, 1, 1, 2, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (4)) THEN - RETURN - ENDIF - - JDIM = 4 - - IF (LOC (PTR (1, 1, 1, 1, 2)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (5)) THEN - RETURN - ENDIF - - JDIM = 5 - - END FUNCTION FIELD_INT5D_GET_LAST_CONTIGUOUS_DIMENSION - INTEGER (KIND=JPIM) FUNCTION FIELD_LOG2D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - LOGICAL(KIND=JPLM), POINTER :: PTR (:,:) - INTEGER*8 :: ISTRIDE (2) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 2 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1)) - LOC (PTR (1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2)) - LOC (PTR (1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - END FUNCTION FIELD_LOG2D_GET_LAST_CONTIGUOUS_DIMENSION - INTEGER (KIND=JPIM) FUNCTION FIELD_LOG3D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - LOGICAL(KIND=JPLM), POINTER :: PTR (:,:,:) - INTEGER*8 :: ISTRIDE (3) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 3 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1, 1)) - LOC (PTR (1, 1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2, 1)) - LOC (PTR (1, 1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - IF (LOC (PTR (1, 1, 2)) - LOC (PTR (1, 1, 1)) /= ISTRIDE (3)) THEN - RETURN - ENDIF - - JDIM = 3 - - END FUNCTION FIELD_LOG3D_GET_LAST_CONTIGUOUS_DIMENSION - INTEGER (KIND=JPIM) FUNCTION FIELD_LOG4D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - LOGICAL(KIND=JPLM), POINTER :: PTR (:,:,:,:) - INTEGER*8 :: ISTRIDE (4) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 4 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1, 1, 1)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2, 1, 1)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - IF (LOC (PTR (1, 1, 2, 1)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (3)) THEN - RETURN - ENDIF - - JDIM = 3 - - IF (LOC (PTR (1, 1, 1, 2)) - LOC (PTR (1, 1, 1, 1)) /= ISTRIDE (4)) THEN - RETURN - ENDIF - - JDIM = 4 - - END FUNCTION FIELD_LOG4D_GET_LAST_CONTIGUOUS_DIMENSION - INTEGER (KIND=JPIM) FUNCTION FIELD_LOG5D_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM) - LOGICAL(KIND=JPLM), POINTER :: PTR (:,:,:,:,:) - INTEGER*8 :: ISTRIDE (5) - INTEGER (KIND=JPIM) :: J - - ISTRIDE (1) = KIND (PTR) - DO J = 2, 5 - ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1) - ENDDO - - JDIM = 0 - IF (LOC (PTR (2, 1, 1, 1, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (1)) THEN - RETURN - ENDIF - - JDIM = 1 - - IF (LOC (PTR (1, 2, 1, 1, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (2)) THEN - RETURN - ENDIF - - JDIM = 2 - - IF (LOC (PTR (1, 1, 2, 1, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (3)) THEN - RETURN - ENDIF - - JDIM = 3 - - IF (LOC (PTR (1, 1, 1, 2, 1)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (4)) THEN - RETURN - ENDIF - - JDIM = 4 - - IF (LOC (PTR (1, 1, 1, 1, 2)) - LOC (PTR (1, 1, 1, 1, 1)) /= ISTRIDE (5)) THEN - RETURN - ENDIF - - JDIM = 5 - - END FUNCTION FIELD_LOG5D_GET_LAST_CONTIGUOUS_DIMENSION - -END MODULE FIELD_MODULE From 20600d9e0d2f87d10194d17bce080df67b62e949 Mon Sep 17 00:00:00 2001 From: Michael Lange Date: Wed, 20 Mar 2024 10:08:59 +0000 Subject: [PATCH 5/5] Loki: Re-introduce `enable_imports` in scheduler config --- src/ecwam/ecwam_loki.config | 1 + src/ecwam/ecwam_loki_gpu.config | 1 + 2 files changed, 2 insertions(+) diff --git a/src/ecwam/ecwam_loki.config b/src/ecwam/ecwam_loki.config index 829822b30..a5aac24d4 100644 --- a/src/ecwam/ecwam_loki.config +++ b/src/ecwam/ecwam_loki.config @@ -3,6 +3,7 @@ mode = "idem" role = "kernel" expand = true strict = true +enable_imports = true # Ensure that we are never adding these to the tree, and thus # do not attempt to look up the source files for these. diff --git a/src/ecwam/ecwam_loki_gpu.config b/src/ecwam/ecwam_loki_gpu.config index 6e52ec5a2..2a26548db 100644 --- a/src/ecwam/ecwam_loki_gpu.config +++ b/src/ecwam/ecwam_loki_gpu.config @@ -3,6 +3,7 @@ mode = "idem" role = "kernel" expand = true strict = true +enable_imports = true # Ensure that we are never adding these to the tree, and thus # do not attempt to look up the source files for these.