diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 69cac7473..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}) @@ -437,7 +433,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,19 +468,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 + 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( @@ -499,7 +498,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} ) @@ -517,19 +516,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-stack/" ${fnc} ".idem_stack.F90") - list(APPEND loki_idem_stack_srcs ${fnm}) + 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 + 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( @@ -544,7 +546,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} ) @@ -567,105 +569,110 @@ 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} - ) - - 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} + 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 + 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( + 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() @@ -682,29 +689,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/ecwam/ecwam_loki.config b/src/ecwam/ecwam_loki.config index fd95a55b2..a5aac24d4 100644 --- a/src/ecwam/ecwam_loki.config +++ b/src/ecwam/ecwam_loki.config @@ -3,36 +3,34 @@ 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. disable = [ - "DR_HOOK", "lhook", "jphook", "omp_get_wtime", "flush", "jwim", - "jwrb", "jwru", "jwro", "environment", "frequency", - "forcing_fields", "intgt_param_fields", "wave2ocean", "abort1", - "iu06" + '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'] + 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" - ] - 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 302bf9685..2a26548db 100644 --- a/src/ecwam/ecwam_loki_gpu.config +++ b/src/ecwam/ecwam_loki_gpu.config @@ -3,41 +3,33 @@ 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. disable = [ - "DR_HOOK", "lhook", "jphook", "omp_get_wtime", "flush", "jwim", - "jwrb", "jwru", "jwro", "environment", "frequency", - "forcing_fields", "intgt_param_fields", "wave2ocean", "abort1", - "iu06" + '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'] + 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 real_kind = 'JWRB' # Define indices and bounds for array dimensions 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 diff --git a/src/programs/CMakeLists.txt b/src/programs/CMakeLists.txt index 7af5545e9..63865b91a 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)