fckit-0.14.3/0000775000175000017500000000000015202607540013064 5ustar alastairalastairfckit-0.14.3/VERSION0000664000175000017500000000001015202607540014123 0ustar alastairalastair0.14.3 fckit-0.14.3/src/0000775000175000017500000000000015202607540013653 5ustar alastairalastairfckit-0.14.3/src/sandbox/0000775000175000017500000000000015202607540015311 5ustar alastairalastairfckit-0.14.3/src/sandbox/CMakeLists.txt0000664000175000017500000000057215202607540020055 0ustar alastairalastair# (C) Copyright 2013 ECMWF. # # 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. fckit-0.14.3/src/tests/0000775000175000017500000000000015202607540015015 5ustar alastairalastairfckit-0.14.3/src/tests/test_configuration_fortcode.F900000664000175000017500000000224315202607540023071 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. function c_get_a( conf_cptr ) result(a) bind(c) use, intrinsic :: iso_c_binding, only : c_ptr, c_int use fckit_configuration_module implicit none integer(c_int) :: a type(c_ptr), value :: conf_cptr type(fckit_configuration) :: conf write(0,*) "c_get_a ..." conf = fckit_configuration( conf_cptr ) if( .not. conf%get("a",a) ) a = 0 write(0,*) "c_get_a ... done" end function !! Following function could be called instead in above function "c_get_a" as: !! a = get_a( fckit_configuration( conf_c_ptr ) ) function get_a( conf ) result(a) use fckit_configuration_module implicit none integer :: a type(fckit_configuration), intent(in) :: conf write(0,*) "get_a ..." if( .not. conf%get("a",a) ) a = 0 write(0,*) "get_a ... done" end function fckit-0.14.3/src/tests/test_configuration.F900000664000175000017500000002100015202607540021174 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fctest.h" ! ----------------------------------------------------------------------------- TESTSUITE(fctest_fckit_configuration) ! ----------------------------------------------------------------------------- TESTSUITE_INIT use fckit_module call fckit_main%init() END_TESTSUITE_INIT ! ----------------------------------------------------------------------------- TESTSUITE_FINALIZE use fckit_module call fckit_main%final() END_TESTSUITE_FINALIZE ! ----------------------------------------------------------------------------- TEST( test_configuration ) #if 1 use fckit_configuration_module use fckit_log_module type(fckit_Configuration) :: config type(fckit_Configuration) :: nested type(fckit_Configuration), allocatable :: list(:) logical :: found logical :: logval integer :: intval integer :: j type(fckit_Configuration) :: anested type(fckit_Configuration), allocatable :: alist(:) write(0,*) "~~~~~~~~~~~~~~ SCOPE BEGIN ~~~~~~~~~~~~~~~" ! --------------------- SET ------------------ ! Corresponding YAML: ! { ! nested: ! list: ! - ! l1: 21 ! l2: 22 ! - ! l1: 21 ! l2: 22 ! n1: 11 ! n2: 12 ! p1: 1 ! p2: 2 ! logical : True ! } config = fckit_Configuration() call config%set("p1",1) call config%set("p2",2) call config%set("logical_true",.True.) call config%set("logical_false",.False.) nested = fckit_Configuration() call nested%set("n1",11) call nested%set("n2",12) allocate( list(2) ) do j=1,2 list(j) = fckit_Configuration() call list(j)%set("l1",21) call list(j)%set("l2",22) enddo call nested%set("list",list) #if ! FCKIT_HAVE_FINAL || FCKIT_FINAL_BROKEN_FOR_AUTOMATIC_ARRAY do j=1,2 call list(j)%final() enddo #endif call config%set("nested",nested) #if ! FCKIT_HAVE_FINAL call nested%final() #endif ! --------------------- JSON ------------------ call fckit_log%info("config = "//config%json()) FCTEST_CHECK_EQUAL( config%owners(), 1 ) ! --------------------- GET ------------------ FCTEST_CHECK_EQUAL( config%size(), 5 ) FCTEST_CHECK_EQUAL( config%key(1), "p1" ) FCTEST_CHECK_EQUAL( config%key(2), "p2" ) FCTEST_CHECK_EQUAL( config%key(3), "logical_true" ) FCTEST_CHECK_EQUAL( config%key(4), "logical_false" ) FCTEST_CHECK_EQUAL( config%key(5), "nested" ) found = config%get("p1",intval) FCTEST_CHECK( found ) FCTEST_CHECK_EQUAL( intval , 1 ) found = config%get("logical_true",logval) FCTEST_CHECK( found ) FCTEST_CHECK( logval ) found = config%get("logical_false",logval) FCTEST_CHECK( found ) FCTEST_CHECK( .not. logval ) found = config%get("nested",anested) FCTEST_CHECK( found ) found = anested%get("n1",intval) FCTEST_CHECK( found ) FCTEST_CHECK_EQUAL(intval, 11) found = anested%get("list",alist) FCTEST_CHECK( found ) FCTEST_CHECK_EQUAL( size(alist), 2 ) found = alist(1)%get("l1",intval) FCTEST_CHECK( found ) FCTEST_CHECK_EQUAL(intval, 21) found = alist(1)%get("l2",intval) FCTEST_CHECK( found ) FCTEST_CHECK_EQUAL(intval, 22) found = alist(2)%get("l1",intval) FCTEST_CHECK( found ) FCTEST_CHECK_EQUAL(intval, 21) found = alist(2)%get("l2",intval) FCTEST_CHECK( found ) FCTEST_CHECK_EQUAL(intval, 22) write(0,*) "deallocate alist..." #if ! FCKIT_HAVE_FINAL || FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY write(0,*) " + deallocate_fckit_configuration(alist)" call deallocate_fckit_configuration(alist) #else write(0,*) "Rely on automatic deallocation" ! write(0,*) " + deallocate(alist)" ! deallocate(alist) #endif write(0,*) "deallocate alist... done" call anested%final() ! There is a reported PGI/16.7 bug that makes this test segfault here. ! PGI/17.1 has this bug fixed. ! --------------------------------------------- write(0,*) "config%owners() = ", config%owners() #if ! FCKIT_HAVE_FINAL call config%final() #endif write(0,*) "~~~~~~~~~~~~~~~ SCOPE END ~~~~~~~~~~~~~~~~" #else #warning Test "test_configuration" disabled #endif END_TEST ! ----------------------------------------------------------------------------- TEST(test_configuration_json_string) #if 1 use fckit_configuration_module use fckit_log_module type(fckit_Configuration) :: config type(fckit_Configuration), allocatable :: records(:) character (len=:), allocatable :: name character (len=:), allocatable :: json character(len=1024) :: msg integer :: age integer :: jrec write(0,*) "~~~~~~~~~~~~~~ SCOPE BEGIN ~~~~~~~~~~~~~~~" allocate( character(len=256) :: json ) json='{"records":['//& & '{"name":"Joe", "age":30},'//& & '{"name":"Alison","age":43}' //& & ']}' config = fckit_YAMLConfiguration(json) call fckit_log%info(config%json()) if( config%get("records",records) ) then do jrec=1,size(records) FCTEST_CHECK( records(jrec)%get("name",name) ) FCTEST_CHECK( records(jrec)%get("age",age) ) write(msg,'(2A,I0,A)') name," is ",age," years old"; call fckit_log%info(msg) enddo write(0,*) "deallocate records..." #if ! FCKIT_HAVE_FINAL || FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY call deallocate_fckit_configuration(records) #else write(0,*) "Rely on automatic deallocation" !if( allocated(records) ) deallocate(records) #endif write(0,*) "deallocate records... done" endif write(0,*) "config%owners() = ", config%owners() #if ! FCKIT_HAVE_FINAL call config%final() #endif write(0,*) "~~~~~~~~~~~~~~~ SCOPE END ~~~~~~~~~~~~~~~~" #else #warning Test "test_configuration_json_string" disabled #endif END_TEST TEST(test_configuration_json_file) #if 1 use fckit_configuration_module use fckit_pathname_module use fckit_log_module type(fckit_Configuration) :: config type(fckit_Configuration), allocatable :: records(:) type(fckit_Configuration) :: location character(len=:), allocatable :: name, company, street, city character(len=:), allocatable :: variables(:) integer :: age integer :: jrec logical :: logval character(len=1024) :: msg write(0,*) "~~~~~~~~~~~~~~ SCOPE BEGIN ~~~~~~~~~~~~~~~" ! Write a json file OPEN (UNIT=9 , FILE="fctest_configuration.json", STATUS='REPLACE') write(9,'(A)') '{"location":{"city":"Reading","company":"ECMWF","street":"Shinfield Road"},'//& &'"records":[{"age":42,"name":"Anne"},{"age":36,"name":"Bob"}],"trueval": true ,"falseval":false,'//& &'"variables":["u","o3","co2"]}' CLOSE(9) config = fckit_YAMLConfiguration( fckit_PathName("fctest_configuration.json") ) call fckit_log%info("config = "//config%json(),flush=.true.) if( config%get("records",records) ) then do jrec=1,size(records) FCTEST_CHECK( records(jrec)%get("name",name) ) FCTEST_CHECK( records(jrec)%get("age",age) ) write(msg,'(2A,I0,A)') name," is ",age," years old"; call fckit_log%info(msg) enddo write(0,*) "deallocate records..." #if ! FCKIT_HAVE_FINAL || FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY call deallocate_fckit_configuration(records) #else write(0,*) "Rely on automatic deallocation" !deallocate(records) #endif write(0,*) "deallocate records... done" endif if( config%get("location",location) ) then call fckit_log%info("location = "//location%json(),flush=.true.) if( location%get("company",company) ) then write(0,*) "company = ",company endif if( location%get("street",street) ) then write(0,*) "street = ",street endif if( location%get("city",city) ) then write(0,*) "city = ",city endif #if ! FCKIT_HAVE_FINAL call location%final() #endif endif if( config%get("trueval",logval) ) then FCTEST_CHECK( logval ) endif if( config%get("falseval",logval) ) then FCTEST_CHECK( .not. logval ) endif if( config%get("variables",variables) ) then write(0,*) "variables: ", variables if( allocated(variables) ) deallocate(variables) endif write(0,*) "config%owners() = ", config%owners() #if ! FCKIT_HAVE_FINAL call config%final() #endif write(0,*) "~~~~~~~~~~~~~~~ SCOPE END ~~~~~~~~~~~~~~~~" #else #warning Test "test_configuration_json_file" disabled #endif END_TEST ! ----------------------------------------------------------------------------- END_TESTSUITE fckit-0.14.3/src/tests/test_cpp.cc0000664000175000017500000000364315202607540017153 0ustar alastairalastair/* * (C) Copyright 2013 ECMWF. * * 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. */ #include "eckit/mpi/Comm.h" #include "fckit/Libfckit.h" #include "fckit/Log.h" #include "fckit/Main.h" using namespace fckit; extern "C" { void run(); } #include #include "eckit/log/OStreamTarget.h" #include "eckit/log/PrefixTarget.h" namespace fckit { namespace test { class Libdummy { public: static Libdummy& instance() { static Libdummy lib; return lib; } void finalise() { traceChannel_.reset( new eckit::Channel() ); } eckit::Channel& traceChannel() { if ( traceChannel_ ) return *traceChannel_; traceChannel_.reset( new eckit::Channel( new eckit::PrefixTarget( "FCKIT_TRACE", new eckit::OStreamTarget( eckit::Log::info() ) ) ) ); return *traceChannel_; } private: std::unique_ptr traceChannel_; }; } // namespace test } // namespace fckit int main( int argc, char* argv[] ) { Main::initialize( argc, argv ); Main::instance().taskID( eckit::mpi::comm().rank() ); test::Libdummy::instance().traceChannel() << "before configure of logging" << std::endl; if ( Main::instance().taskID() == 0 ) { Log::setFortranUnit( Log::output_unit(), Log::TIMESTAMP ); Log::addFile( "fckit_test_cpp.log", Log::TIMESTAMP ); } else { Log::reset(); } test::Libdummy::instance().traceChannel() << "after configure of logging" << std::endl; run(); Log::debug() << "message from Libfckit" << std::endl; test::Libdummy::instance().finalise(); Main::finalize(); return 0; } fckit-0.14.3/src/tests/test_tensor.cc0000664000175000017500000001362215202607540017701 0ustar alastairalastair#include #include "eckit/linalg/Tensor.h" #include "eckit/exception/Exceptions.h" // ========= preliminary checks on tensor size, rank and layout flag ========= template void cxx_check_tensor(void* tensor_cptr, size_t expected_size, size_t expected_rank, int layout) { typename eckit::linalg::Tensor* tensor_ptr = static_cast*>(tensor_cptr); ASSERT(tensor_ptr->size() == expected_size); ASSERT(tensor_ptr->shape().size() == expected_rank); ASSERT(static_cast(tensor_ptr->layout()) == layout); } // ========= checks on tensor data ========= template void cxx_check_tensor_layout(void* tensor_cptr, T* data, size_t data_size, LayoutChecker layoutChecker) { typename eckit::linalg::Tensor* tensor_ptr = static_cast*>(tensor_cptr); // expected data size ASSERT(tensor_ptr->size() == data_size); // first of all, assert that the data is correctly wrapped.. for (int i=0; idata()+i) == *(data+i)); } // check layout layoutChecker(data, tensor_ptr); }; // (note this could be templetized further..) // data checker rank 3 template void layout_check_rank_3(T* data, typename eckit::linalg::Tensor* tensor_ptr) { if (tensor_ptr->layout() == eckit::linalg::Tensor::Layout::RowMajor){ // row-major layout int count=0; for (int i=0; ishape()[0]; i++){ for (int j=0; jshape()[1]; j++){ for (int k=0; kshape()[2]; k++){ ASSERT( (*tensor_ptr)(i,j,k) == *(data+count)); count++; } } } } else { // col-major layout int count=0; for (int i=0; ishape()[2]; i++){ for (int j=0; jshape()[1]; j++){ for (int k=0; kshape()[0]; k++){ ASSERT( (*tensor_ptr)(k,j,i) == *(data+count)); count++; } } } } }; // data checker rank 4 template void layout_check_rank_4(T* data, typename eckit::linalg::Tensor* tensor_ptr) { if (tensor_ptr->layout() == eckit::linalg::Tensor::Layout::RowMajor){ // row-major layout int count=0; for (int i=0; ishape()[0]; i++){ for (int j=0; jshape()[1]; j++){ for (int k=0; kshape()[2]; k++) for (int l=0; lshape()[3]; l++){ ASSERT( (*tensor_ptr)(i,j,k,l) == *(data+count)); count++; } } } } else { // col-major layout int count=0; for (int i=0; ishape()[3]; i++){ for (int j=0; jshape()[2]; j++){ for (int k=0; kshape()[1]; k++) for (int l=0; lshape()[0]; l++){ ASSERT( (*tensor_ptr)(l,k,j,i) == *(data+count)); count++; } } } } }; template T* create_tensor_filled(int* shape, int shape_size, typename T::Layout layout) { // shape ASSERT(shape_size>0); std::vector shape_vec; for (int i=0; i 0); shape_vec.push_back(*(shape+i)); } T* ptr = new T(shape_vec, layout); ptr->zero(); // zero-initialise it (to make sure it is writable) return ptr; } extern "C" { // ---------- TensorFloat checks.. void cxx_check_tensor_float(void* tensor_cptr, size_t expected_size, size_t expected_rank, int layout) { return cxx_check_tensor(tensor_cptr, expected_size, expected_rank, layout); } void cxx_check_tensor_float_layout_rank3(void* tensor_cptr, float* data, size_t data_size) { return cxx_check_tensor_layout( tensor_cptr, data, data_size, layout_check_rank_3 ); } void cxx_check_tensor_float_layout_rank4(void* tensor_cptr, float* data, size_t data_size) { return cxx_check_tensor_layout( tensor_cptr, data, data_size, layout_check_rank_4 ); } void* cxx_create_tensor_float_filled(int* shape, int shape_size, int layout) { return create_tensor_filled( shape, shape_size, static_cast(layout) ); } void cxx_delete_tensor_float(eckit::linalg::TensorFloat* ptr) { delete ptr; } // ---------- TensorDouble checks.. void cxx_check_tensor_double(void* tensor_cptr, size_t expected_size, size_t expected_rank, int layout) { return cxx_check_tensor(tensor_cptr, expected_size, expected_rank, layout); } void cxx_check_tensor_double_layout_rank3(void* tensor_cptr, double* data, size_t data_size) { return cxx_check_tensor_layout( tensor_cptr, data, data_size, layout_check_rank_3 ); } void cxx_check_tensor_double_layout_rank4(void* tensor_cptr, double* data, size_t data_size) { return cxx_check_tensor_layout( tensor_cptr, data, data_size, layout_check_rank_4 ); } void* cxx_create_tensor_double_filled(int* shape, int shape_size, int layout) { return create_tensor_filled( shape, shape_size, static_cast(layout) ); } void cxx_delete_tensor_double(eckit::linalg::TensorDouble* ptr) { delete ptr; } }fckit-0.14.3/src/tests/test_yaml_reader.py0000664000175000017500000000326115202607540020714 0ustar alastairalastair#!/usr/bin/env python3 # (C) Copyright 2024 ECMWF. # # 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. from pathlib import Path import pytest from fckit_yaml_reader import YAML yaml = YAML() @pytest.fixture(scope='module', name='here') def fixture_here(): return Path(__file__).parent @pytest.fixture(scope='function', name='tmpfile') def fixture_tmpfile(here): tmpfile = here / 'tmp.yml' yield tmpfile if tmpfile.exists(): tmpfile.unlink() @pytest.fixture(scope='module', name='refdict') def fxiture_refdict(): return { 'name': 'type config', 'types': [ {'typeA': [ ['memberA', 'real', 3], ['memberB', 'real', 3] ] }, {'typeB': [ ['memberA', 'real', 3], ['memberB', 'int', 2] ] } ] } def test_yaml_parse(here, refdict): """Test parsing capability of fckit_yaml_reader.""" with open(here / 'test_config.yml', 'r') as stream: _dict = yaml.safe_load(stream) assert _dict == refdict def test_yaml_dump(here, refdict, tmpfile): """Test writing capability of fckit_yaml_reader.""" with open(here / tmpfile, 'w') as stream: yaml.dump(refdict, stream) with open(here / tmpfile, 'r') as stream: _dict = yaml.safe_load(stream) assert _dict == refdict fckit-0.14.3/src/tests/test_downstream_fypp/0000775000175000017500000000000015202607540021275 5ustar alastairalastairfckit-0.14.3/src/tests/test_downstream_fypp/test-downstream.sh.in0000775000175000017500000000312015202607540025375 0ustar alastairalastair#!/usr/bin/env bash # Description: # Build downstream example projects # each individually with make/install # # Usage: # test-individual.sh [CMAKE_ARGUMENTS] SOURCE=@CMAKE_CURRENT_SOURCE_DIR@/downstream BUILD_ROOT=@CMAKE_CURRENT_BINARY_DIR@ # Error handling function test_failed { EXIT_CODE=$? { set +ex; } 2>/dev/null if [ $EXIT_CODE -ne 0 ]; then echo "+++++++++++++++++" echo "Test failed" echo "+++++++++++++++++" fi exit $EXIT_CODE } trap test_failed EXIT set -e -o pipefail set -x export fckit_DIR=@PROJECT_BINARY_DIR@ export ecbuild_DIR=@ecbuild_DIR@ COMMON_CMAKE_ARGS=( -DCMAKE_BUILD_TYPE=RelWithDebInfo -DECBUILD_2_COMPAT=OFF -DECBUILD_COMPILE_FLAGS=@CMAKE_CURRENT_SOURCE_DIR@/compile_flags.cmake "$@" ) function build_and_check { local variant=$1 local output_suffix=$2 local build_dir=${BUILD_ROOT}/downstream_${variant} rm -rf "$build_dir" mkdir -p "$build_dir" cd "$build_dir" local cmake_args=("${COMMON_CMAKE_ARGS[@]}") if [ -n "$output_suffix" ]; then cmake_args+=("-DDOWNSTREAM_FYPP_OUTPUT_SUFFIX=${output_suffix}") fi cmake "$SOURCE" "${cmake_args[@]}" make VERBOSE=1 if [ -n "$output_suffix" ]; then test -f "downstream${output_suffix}.F90" test -f "downstream_override${output_suffix}.F90" test ! -e "downstream.F90" test ! -e "downstream_override.F90" else test -f "downstream.F90" test -f "downstream_override.F90" fi bin/main } build_and_check default "" build_and_check suffixed "_custom" { set +ex; } 2>/dev/null echo "+++++++++++++++++" echo "Test passed" echo "+++++++++++++++++" fckit-0.14.3/src/tests/test_downstream_fypp/compile_flags.cmake0000664000175000017500000000151315202607540025103 0ustar alastairalastair# File used to change or override compile flags message("----------- CMAKE_Fortran_FLAGS = ${CMAKE_Fortran_FLAGS}") message("----------- ECBUILD_Fortran_FLAGS = ${ECBUILD_Fortran_FLAGS}") set( DOWNSTREAM_Fortran_FLAGS "-DDOWNSTREAM_Fortran_FLAGS='\"DOWNSTREAM_Fortran_FLAGS\"' ${CMAKE_Fortran_FLAGS} ${ECBUILD_Fortran_FLAGS}" ) set( DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO "-DDOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO='\"DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO\"'" ) set_source_files_properties( downstream.fypp PROPERTIES COMPILE_FLAGS "-DDOWNSTREAM_COMPILE_FLAGS='\"DOWNSTREAM_COMPILE_FLAGS\"'" ) set_source_files_properties( downstream_override.fypp PROPERTIES OVERRIDE_COMPILE_FLAGS "-DDOWNSTREAM_COMPILE_FLAGS='\"DOWNSTREAM_OVERRIDE_COMPILE_FLAGS\"' ${CMAKE_Fortran_FLAGS} ${ECBUILD_Fortran_FLAGS}" ) fckit-0.14.3/src/tests/test_downstream_fypp/downstream/0000775000175000017500000000000015202607540023460 5ustar alastairalastairfckit-0.14.3/src/tests/test_downstream_fypp/downstream/main.F900000664000175000017500000000110115202607540024655 0ustar alastairalastairprogram main use fckit_module, only: fckit_log use downstream use downstream_override implicit none call fckit_log%info("Printing downstream compile flags") call print_downstream_compile_flags() call fckit_log%info("Asserting downstream compile flags") call assert_downstream_compile_flags() call fckit_log%info("Printing downstream_override compile flags") call print_downstream_override_compile_flags() call fckit_log%info("Asserting downstream_override compile flags") call assert_downstream_override_compile_flags() call fckit_log%info("End of main") end programfckit-0.14.3/src/tests/test_downstream_fypp/downstream/downstream_override.fypp0000664000175000017500000000243315202607540030444 0ustar alastairalastairmodule downstream_override implicit none public contains subroutine print_downstream_override_compile_flags() use fckit_module #ifdef DOWNSTREAM_COMPILE_FLAGS call fckit_log%info("DOWNSTREAM_COMPILE_FLAGS = "//trim(DOWNSTREAM_COMPILE_FLAGS)) #else call fckit_log%info("DOWNSTREAM_COMPILE_FLAGS = Not specified") #endif #ifdef DOWNSTREAM_Fortran_FLAGS call fckit_log%info("DOWNSTREAM_Fortran_FLAGS = "//trim(DOWNSTREAM_Fortran_FLAGS)) #else call fckit_log%info("DOWNSTREAM_Fortran_FLAGS = Not specified") #endif #ifdef DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO call fckit_log%info("DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO = "//trim(DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO)) #else call fckit_log%info("DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO = Not specified") #endif end subroutine subroutine assert_downstream_override_compile_flags() use fckit_module #ifndef DOWNSTREAM_COMPILE_FLAGS call fckit_exception%abort("DOWNSTREAM_COMPILE_FLAGS are missing") #endif #ifdef DOWNSTREAM_Fortran_FLAGS call fckit_exception%abort("DOWNSTREAM_Fortran_FLAGS should be missing") #endif #ifdef DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO call fckit_exception%abort("DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO should be missing") #endif end subroutine end module fckit-0.14.3/src/tests/test_downstream_fypp/downstream/downstream.fypp0000664000175000017500000000236515202607540026551 0ustar alastairalastairmodule downstream implicit none public contains subroutine print_downstream_compile_flags() use fckit_module #ifdef DOWNSTREAM_COMPILE_FLAGS call fckit_log%info("DOWNSTREAM_COMPILE_FLAGS = "//trim(DOWNSTREAM_COMPILE_FLAGS)) #else call fckit_log%info("DOWNSTREAM_COMPILE_FLAGS = Not specified") #endif #ifdef DOWNSTREAM_Fortran_FLAGS call fckit_log%info("DOWNSTREAM_Fortran_FLAGS = "//trim(DOWNSTREAM_Fortran_FLAGS)) #else call fckit_log%info("DOWNSTREAM_Fortran_FLAGS = Not specified") #endif #ifdef DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO call fckit_log%info("DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO = "//trim(DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO)) #else call fckit_log%info("DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO = Not specified") #endif end subroutine subroutine assert_downstream_compile_flags() use fckit_module #ifndef DOWNSTREAM_COMPILE_FLAGS call fckit_exception%abort("DOWNSTREAM_COMPILE_FLAGS are missing") #endif #ifndef DOWNSTREAM_Fortran_FLAGS call fckit_exception%abort("DOWNSTREAM_Fortran_FLAGS are missing") #endif #ifndef DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO call fckit_exception%abort("DOWNSTREAM_Fortran_FLAGS_RELWITHDEBINFO are missing") #endif end subroutine end modulefckit-0.14.3/src/tests/test_downstream_fypp/downstream/CMakeLists.txt0000664000175000017500000000126115202607540026220 0ustar alastairalastaircmake_minimum_required( VERSION 3.12 FATAL_ERROR ) find_package( ecbuild REQUIRED ) project( downstream VERSION 0.1.0 LANGUAGES Fortran) find_package( fckit REQUIRED COMPONENTS ECKIT ) ecbuild_add_library( TARGET downstream SOURCES downstream.fypp downstream_override.fypp PUBLIC_LIBS fckit DEFINITIONS _POSIX_C_SOURCE=200809L exclude_from_fypp) set( _fypp_args FYPP_ARGS_EXCLUDE "exclude_from_fypp" ) if( DEFINED DOWNSTREAM_FYPP_OUTPUT_SUFFIX ) list( APPEND _fypp_args OUTPUT_SUFFIX "${DOWNSTREAM_FYPP_OUTPUT_SUFFIX}" ) endif() fckit_target_preprocess_fypp( downstream ${_fypp_args} ) ecbuild_add_executable( TARGET main SOURCES main.F90 LIBS fckit downstream ) fckit-0.14.3/src/tests/test_downstream_fypp/CMakeLists.txt0000664000175000017500000000224215202607540024035 0ustar alastairalastair # This test builds a package that requires fypp processing # It uses the overriding of compile flags, like IFS is using. # # Test created to avoid regression after fixing issue FCKIT-19, # where compile flags were not propagated to fypp-generated files. if( HAVE_TESTS AND HAVE_ECKIT ) configure_file( test-downstream.sh.in ${CMAKE_CURRENT_BINARY_DIR}/test-downstream.sh @ONLY ) unset( _test_args ) if( CMAKE_TOOLCHAIN_FILE ) if( NOT IS_ABSOLUTE ${CMAKE_TOOLCHAIN_FILE}) set( CMAKE_TOOLCHAIN_FILE "${CMAKE_BINARY_DIR}/${CMAKE_TOOLCHAIN_FILE}" ) endif() list( APPEND _test_args "-DCMAKE_TOOLCHAIN_FILE=${CMAKE_TOOLCHAIN_FILE}" ) endif() foreach( lang C CXX Fortran ) if( CMAKE_${lang}_COMPILER ) list( APPEND _test_args "-DCMAKE_${lang}_COMPILER=${CMAKE_${lang}_COMPILER}" ) endif() if( CMAKE_${lang}_FLAGS ) string(REPLACE "--coverage" "" CMAKE_${lang}_FLAGS "${CMAKE_${lang}_FLAGS}") list( APPEND _test_args "-DECBUILD_${lang}_FLAGS=${CMAKE_${lang}_FLAGS}" ) endif() endforeach() add_test( NAME fckit_test_downstream_fypp COMMAND ${CMAKE_CURRENT_BINARY_DIR}/test-downstream.sh ${_test_args} ) endif() fckit-0.14.3/src/tests/test_tensor.F900000664000175000017500000004471215202607540017656 0ustar alastairalastair#include "fckit/fctest.h" ! test fixture for f2c interop module fcta_tensor_f_fxt use fckit_array_module, only: array_view1d interface ! float tensor C++ checks.. subroutine cxx_check_tensor_float(cptr, esize, erank, layout) bind(c,name="cxx_check_tensor_float") use iso_c_binding, only : c_ptr, c_size_t, c_int type(c_ptr), value :: cptr integer(c_size_t), value :: esize integer(c_size_t), value :: erank integer(c_int), value :: layout end subroutine subroutine cxx_check_tensor_float_layout_r3(cptr, data, data_size) & & bind(c,name="cxx_check_tensor_float_layout_rank3") use iso_c_binding, only : c_ptr, c_float, c_size_t, c_int type(c_ptr), value :: cptr real(c_float), dimension(*) :: data integer(c_size_t), intent(in), value :: data_size end subroutine subroutine cxx_check_tensor_float_layout_r4(cptr, data, data_size) & & bind(c,name="cxx_check_tensor_float_layout_rank4") use iso_c_binding, only : c_ptr, c_float, c_size_t, c_int type(c_ptr), value :: cptr real(c_float), dimension(*) :: data integer(c_size_t), intent(in), value :: data_size end subroutine function cxx_create_tensor_float_filled(shape, shape_size, layout) & & bind(c,name="cxx_create_tensor_float_filled") use iso_c_binding, only : c_ptr, c_int integer(c_int), intent(in), dimension(*) :: shape integer(c_int), intent(in), value :: shape_size integer(c_int), intent(in), value :: layout type(c_ptr) :: cxx_create_tensor_float_filled end function subroutine cxx_delete_tensor_float(ptr) & & bind(c,name="cxx_delete_tensor_float") use iso_c_binding, only : c_ptr type(c_ptr), intent(in), value :: ptr end subroutine ! double tensor C++ checks.. subroutine cxx_check_tensor_double(cptr, esize, erank, layout) bind(c,name="cxx_check_tensor_double") use iso_c_binding, only : c_ptr, c_size_t, c_int type(c_ptr), value :: cptr integer(c_size_t), value :: esize integer(c_size_t), value :: erank integer(c_int), value :: layout end subroutine subroutine cxx_check_tensor_double_layout_r3(cptr, data, data_size) & & bind(c,name="cxx_check_tensor_double_layout_rank3") use iso_c_binding, only : c_ptr, c_double, c_size_t, c_int type(c_ptr), value :: cptr real(c_double), dimension(*) :: data integer(c_size_t), intent(in), value :: data_size end subroutine subroutine cxx_check_tensor_double_layout_r4(cptr, data, data_size) & & bind(c,name="cxx_check_tensor_double_layout_rank4") use iso_c_binding, only : c_ptr, c_double, c_size_t, c_int type(c_ptr), value :: cptr real(c_double), dimension(*) :: data integer(c_size_t), intent(in), value :: data_size end subroutine function cxx_create_tensor_double_filled(shape, shape_size, layout) & & bind(c,name="cxx_create_tensor_double_filled") use iso_c_binding, only : c_ptr, c_int integer(c_int), intent(in), dimension(*) :: shape integer(c_int), intent(in), value :: shape_size integer(c_int), intent(in), value :: layout type(c_ptr) :: cxx_create_tensor_double_filled end function subroutine cxx_delete_tensor_double(ptr) & & bind(c,name="cxx_delete_tensor_double") use iso_c_binding, only : c_ptr type(c_ptr), intent(in), value :: ptr end subroutine end interface contains ! float tensor checks.. subroutine check_tensor_float(cptr, esize, erank, layout) use iso_c_binding, only : c_ptr, c_size_t, c_int type(c_ptr) :: cptr integer(c_size_t) :: esize integer(c_size_t) :: erank integer(c_int) :: layout call cxx_check_tensor_float(cptr, esize, erank, layout) end subroutine subroutine check_tensor_float_layout_r3(cptr, data) use iso_c_binding, only : c_ptr, c_float, c_size_t, c_int type(c_ptr), value :: cptr real(c_float), intent(in), target :: data(:,:,:) real(c_float), pointer :: data_vec(:) integer(c_size_t) :: shape_vec(3) integer(c_size_t) :: data_rank integer(c_size_t) :: data_size data_vec => array_view1d( data ) shape_vec = shape(data) data_rank = size(shape_vec) data_size = size(data) call cxx_check_tensor_float_layout_r3(cptr, data_vec, data_size ) end subroutine subroutine check_tensor_float_layout_r4(cptr, data) use iso_c_binding, only : c_ptr, c_float, c_size_t, c_int type(c_ptr), value :: cptr real(c_float), intent(in), target :: data(:,:,:,:) real(c_float), pointer :: data_vec(:) integer(c_size_t) :: shape_vec(4) integer(c_size_t) :: data_rank integer(c_size_t) :: data_size data_vec => array_view1d( data ) shape_vec = shape(data) data_rank = size(shape_vec) data_size = size(data) call cxx_check_tensor_float_layout_r4(cptr, data_vec, data_size ) end subroutine function create_tensor_float_filled(shape, shape_size, layout) use iso_c_binding, only : c_ptr, c_int integer(c_int), intent(in), dimension(*) :: shape integer(c_int), intent(in), value :: shape_size integer(c_int), intent(in), value :: layout type(c_ptr) :: create_tensor_float_filled create_tensor_float_filled = cxx_create_tensor_float_filled(shape, shape_size, layout) end function subroutine delete_tensor_float(ptr) use iso_c_binding, only : c_ptr type(c_ptr), intent(in) :: ptr call cxx_delete_tensor_float(ptr) end subroutine ! double tensor checks.. subroutine check_tensor_double(cptr, esize, erank, layout) use iso_c_binding, only : c_ptr, c_size_t, c_int type(c_ptr) :: cptr integer(c_size_t) :: esize integer(c_size_t) :: erank integer(c_int) :: layout call cxx_check_tensor_double(cptr, esize, erank, layout) end subroutine subroutine check_tensor_double_layout_r3(cptr, data) use iso_c_binding, only : c_ptr, c_double, c_size_t, c_int type(c_ptr), value :: cptr real(c_double), intent(in), target :: data(:,:,:) real(c_double), pointer :: data_vec(:) integer(c_size_t) :: shape_vec(3) integer(c_size_t) :: data_rank integer(c_size_t) :: data_size data_vec => array_view1d( data ) shape_vec = shape(data) data_rank = size(shape_vec) data_size = size(data) call cxx_check_tensor_double_layout_r3(cptr, data_vec, data_size ) end subroutine subroutine check_tensor_double_layout_r4(cptr, data) use iso_c_binding, only : c_ptr, c_double, c_size_t, c_int type(c_ptr), value :: cptr real(c_double), intent(in), target :: data(:,:,:,:) real(c_double), pointer :: data_vec(:) integer(c_size_t) :: shape_vec(4) integer(c_size_t) :: data_rank integer(c_size_t) :: data_size data_vec => array_view1d( data ) shape_vec = shape(data) data_rank = size(shape_vec) data_size = size(data) call cxx_check_tensor_double_layout_r4(cptr, data_vec, data_size ) end subroutine function create_tensor_double_filled(shape, shape_size, layout) use iso_c_binding, only : c_ptr, c_int integer(c_int), intent(in), dimension(*) :: shape integer(c_int), intent(in), value :: shape_size integer(c_int), intent(in), value :: layout type(c_ptr) :: create_tensor_double_filled create_tensor_double_filled = cxx_create_tensor_double_filled(shape, shape_size, layout) end function subroutine delete_tensor_double(ptr) use iso_c_binding, only : c_ptr type(c_ptr), intent(in) :: ptr call cxx_delete_tensor_double(ptr) end subroutine end module fcta_tensor_f_fxt ! ----------------------------------------------------------------------------- TESTSUITE_WITH_FIXTURE(fctest_test_tensor_suite, fcta_tensor_f_fxt) ! ----------------------------------------------------------------------------- TESTSUITE_INIT use fckit_module call fckit_main%init() END_TESTSUITE_INIT ! ----------------------------------------------------------------------------- TESTSUITE_FINALIZE use fckit_module call fckit_main%final() END_TESTSUITE_FINALIZE ! ----------------------------------------------------------------------------- ! ============= TensorFloat tests ============= TEST( test_float_tensor_creation ) #if 1 use iso_c_binding, only : c_float, c_size_t use fckit_tensor_module, only : fckit_tensor_real32 type(fckit_tensor_real32) :: tensor_empty type(fckit_tensor_real32) :: tensor_from_shape type(fckit_tensor_real32) :: tensor_rank1 type(fckit_tensor_real32) :: tensor_rank2 type(fckit_tensor_real32) :: tensor_rank3 type(fckit_tensor_real32) :: tensor_rank4 integer(c_size_t) :: shape(4) = (/ 4,2,3,4 /) real(c_float) :: data_rank1(10) = 0.0 real(c_float) :: data_rank2(3,4) real(c_float) :: data_rank3(3,3,3) real(c_float) :: data_rank4(2,3,4,5) integer(c_size_t) :: tensor_size integer(c_size_t) :: rank integer(c_size_t), allocatable :: tensor_shape(:) ! an empty tensor tensor_empty = fckit_tensor_real32() ! a tensor from shape tensor_from_shape = fckit_tensor_real32(shape) ! a tensor from an array tensor_rank1 = fckit_tensor_real32(data_rank1) ! a tensor from an array rank 2 data_rank2(1,:) = 0.0 data_rank2(2,:) = 1.0 data_rank2(3,:) = 2.0 tensor_rank2 = fckit_tensor_real32(data_rank2) ! a tensor from an array rank 3 data_rank3 = 0.0 tensor_rank3 = fckit_tensor_real32(data_rank3) ! a tensor from an array rank 4 data_rank4 = 0.0 tensor_rank4 = fckit_tensor_real32(data_rank4) ! check rank1 - tensor size/shape tensor_size = tensor_rank1%size() rank = tensor_rank1%rank() tensor_shape = tensor_rank1%shape() FCTEST_CHECK_EQUAL( tensor_size , 10 ) FCTEST_CHECK_EQUAL( size(tensor_shape) , 1 ) FCTEST_CHECK_EQUAL( tensor_shape(1) , 10 ) deallocate(tensor_shape) ! check rank2 - tensor size/shape tensor_size = tensor_rank2%size() rank = tensor_rank2%rank() tensor_shape = tensor_rank2%shape() FCTEST_CHECK_EQUAL( tensor_size , 3*4 ) FCTEST_CHECK_EQUAL( size(tensor_shape) , 2 ) FCTEST_CHECK_EQUAL( tensor_shape(1) , 3 ) FCTEST_CHECK_EQUAL( tensor_shape(2) , 4 ) deallocate(tensor_shape) ! check rank3 - tensor size/shape tensor_size = tensor_rank3%size() rank = tensor_rank3%rank() tensor_shape = tensor_rank3%shape() FCTEST_CHECK_EQUAL( tensor_size , 3*3*3 ) FCTEST_CHECK_EQUAL( size(tensor_shape) , 3 ) FCTEST_CHECK_EQUAL( tensor_shape(1) , 3 ) FCTEST_CHECK_EQUAL( tensor_shape(2) , 3 ) FCTEST_CHECK_EQUAL( tensor_shape(3) , 3 ) deallocate(tensor_shape) ! check rank4 - tensor size/shape tensor_size = tensor_rank4%size() rank = tensor_rank3%rank() tensor_shape = tensor_rank4%shape() FCTEST_CHECK_EQUAL( tensor_size , 2*3*4*5 ) FCTEST_CHECK_EQUAL( size(tensor_shape) , 4 ) FCTEST_CHECK_EQUAL( tensor_shape(1) , 2 ) FCTEST_CHECK_EQUAL( tensor_shape(2) , 3 ) FCTEST_CHECK_EQUAL( tensor_shape(3) , 4 ) FCTEST_CHECK_EQUAL( tensor_shape(4) , 5 ) deallocate(tensor_shape) ! finalise call tensor_empty%final() call tensor_from_shape%final() call tensor_rank1%final() call tensor_rank2%final() call tensor_rank3%final() call tensor_rank4%final() #else #warning Test "test_float_tensor_creation" disabled #endif END_TEST TEST( test_tensor_float_interop ) #if 1 use iso_c_binding, only : c_float, c_size_t use fckit_tensor_module, only : fckit_tensor_real32, fckit_tensor type(fckit_tensor_real32) :: tensor_r3 type(fckit_tensor_real32) :: tensor_r4 real(c_float) :: data_r3(3,3,3) real(c_float) :: data_r4(2,4,5,6) integer(c_size_t) :: expected_size integer(c_size_t) :: expected_rank integer(c_int) :: expected_layout ! ---------------------- rank 3 data_r3(1,:,:) = 0.04 data_r3(2,:,:) = 1.04 data_r3(3,:,:) = 2.04 tensor_r3 = fckit_tensor_real32(data_r3, fckit_tensor%layout_rowmajor()) expected_size = 3*3*3 expected_rank = 3 expected_layout = fckit_tensor%layout_rowmajor() ! check tensor info from c++ call check_tensor_float(tensor_r3%c_ptr(), expected_size, expected_rank, expected_layout) ! check internal data.. call check_tensor_float_layout_r3(tensor_r3%c_ptr(), data_r3) ! ---------------------- rank 4 data_r4(1,:,:,:) = 1.14 data_r4(2,:,:,:) = 2.24 data_r4(:,:,:,6) = 3.34 tensor_r4 = fckit_tensor_real32(data_r4) ! layout is colmajor (by default) expected_size = 2*4*5*6 expected_rank = 4 expected_layout = fckit_tensor%layout_colmajor() ! check tensor info from c++ call check_tensor_float(tensor_r4%c_ptr(), expected_size, expected_rank, expected_layout) ! check internal data.. call check_tensor_float_layout_r4(tensor_r4%c_ptr(), data_r4) #else #warning Test "test_tensor_float_interop" disabled #endif END_TEST TEST ( test_tensor_float_creation_from_cpp ) #if 1 use iso_c_binding, only : c_ptr, c_int, c_size_t use fckit_tensor_module, only : fckit_tensor_real32, fckit_tensor type(fckit_tensor_real32) :: tensor integer(c_int) :: tensor_shape_input(4) = (/ 4,2,3,4 /) integer(c_size_t), allocatable :: tensor_shape(:) integer(c_size_t) :: expected_size = 4*2*3*4 integer(c_size_t) :: expected_rank = 4 integer(c_size_t) :: expected_shape(4) = (/ 4,2,3,4 /) call tensor%reset_c_ptr(create_tensor_float_filled(tensor_shape_input, size(tensor_shape_input), fckit_tensor%layout_colmajor())) FCTEST_CHECK_EQUAL( tensor%size(), expected_size ) FCTEST_CHECK_EQUAL( tensor%rank(), expected_rank ) tensor_shape = tensor%shape() FCTEST_CHECK_EQUAL( tensor_shape(1), expected_shape(1) ) FCTEST_CHECK_EQUAL( tensor_shape(2), expected_shape(2) ) FCTEST_CHECK_EQUAL( tensor_shape(3), expected_shape(3) ) FCTEST_CHECK_EQUAL( tensor_shape(4), expected_shape(4) ) FCTEST_CHECK_EQUAL( tensor%layout(), fckit_tensor%layout_colmajor() ) ! deallocation deallocate(tensor_shape) call delete_tensor_float(tensor%c_ptr()) #else #warning Test "test_tensor_float_creation_from_cpp" disabled #endif END_TEST ! ============= TensorDouble tests ============= TEST( test_double_tensor_creation ) #if 1 use iso_c_binding, only : c_double, c_size_t use fckit_tensor_module, only : fckit_tensor_real64 type(fckit_tensor_real64) :: tensor_empty type(fckit_tensor_real64) :: tensor_from_shape type(fckit_tensor_real64) :: tensor_rank1 type(fckit_tensor_real64) :: tensor_rank2 type(fckit_tensor_real64) :: tensor_rank3 type(fckit_tensor_real64) :: tensor_rank4 integer(c_size_t) :: shape(4) = (/ 4,2,3,4 /) real(c_double) :: data_rank1(10) = 0.0 real(c_double) :: data_rank2(3,4) real(c_double) :: data_rank3(3,3,3) real(c_double) :: data_rank4(2,3,4,5) integer(c_size_t) :: tensor_size integer(c_size_t) :: rank integer(c_size_t), allocatable :: tensor_shape(:) ! an empty tensor tensor_empty = fckit_tensor_real64() ! a tensor from shape tensor_from_shape = fckit_tensor_real64(shape) ! a tensor from an array tensor_rank1 = fckit_tensor_real64(data_rank1) ! a tensor from an array rank 2 data_rank2(1,:) = 0.06 data_rank2(2,:) = 1.06 data_rank2(3,:) = 2.06 tensor_rank2 = fckit_tensor_real64(data_rank2) ! a tensor from an array rank 3 data_rank3 = 0.0 tensor_rank3 = fckit_tensor_real64(data_rank3) ! a tensor from an array rank 4 data_rank4 = 0.0 tensor_rank4 = fckit_tensor_real64(data_rank4) ! check rank1 - tensor size/shape tensor_size = tensor_rank1%size() rank = tensor_rank1%rank() tensor_shape = tensor_rank1%shape() FCTEST_CHECK_EQUAL( tensor_size , 10 ) FCTEST_CHECK_EQUAL( size(tensor_shape) , 1 ) FCTEST_CHECK_EQUAL( tensor_shape(1) , 10 ) deallocate(tensor_shape) ! check rank2 - tensor size/shape tensor_size = tensor_rank2%size() rank = tensor_rank2%rank() tensor_shape = tensor_rank2%shape() FCTEST_CHECK_EQUAL( tensor_size , 3*4 ) FCTEST_CHECK_EQUAL( size(tensor_shape) , 2 ) FCTEST_CHECK_EQUAL( tensor_shape(1) , 3 ) FCTEST_CHECK_EQUAL( tensor_shape(2) , 4 ) deallocate(tensor_shape) ! check rank3 - tensor size/shape tensor_size = tensor_rank3%size() rank = tensor_rank3%rank() tensor_shape = tensor_rank3%shape() FCTEST_CHECK_EQUAL( tensor_size , 3*3*3 ) FCTEST_CHECK_EQUAL( size(tensor_shape) , 3 ) FCTEST_CHECK_EQUAL( tensor_shape(1) , 3 ) FCTEST_CHECK_EQUAL( tensor_shape(2) , 3 ) FCTEST_CHECK_EQUAL( tensor_shape(3) , 3 ) deallocate(tensor_shape) ! check rank4 - tensor size/shape tensor_size = tensor_rank4%size() rank = tensor_rank3%rank() ! allocate(tensor_shape(rank)) tensor_shape = tensor_rank4%shape() FCTEST_CHECK_EQUAL( tensor_size , 2*3*4*5 ) FCTEST_CHECK_EQUAL( size(tensor_shape) , 4 ) FCTEST_CHECK_EQUAL( tensor_shape(1) , 2 ) FCTEST_CHECK_EQUAL( tensor_shape(2) , 3 ) FCTEST_CHECK_EQUAL( tensor_shape(3) , 4 ) FCTEST_CHECK_EQUAL( tensor_shape(4) , 5 ) deallocate(tensor_shape) ! finalise call tensor_empty%final() call tensor_from_shape%final() call tensor_rank1%final() call tensor_rank2%final() call tensor_rank3%final() call tensor_rank4%final() #else #warning Test "test_double_tensor_creation" disabled #endif END_TEST TEST( test_tensor_double_interop ) #if 1 use iso_c_binding, only : c_double, c_size_t use fckit_tensor_module, only : fckit_tensor_real64, fckit_tensor type(fckit_tensor_real64) :: tensor_r3 type(fckit_tensor_real64) :: tensor_r4 real(c_double) :: data_r3(3,3,3) real(c_double) :: data_r4(2,4,5,6) integer(c_size_t) :: expected_size integer(c_size_t) :: expected_rank integer(c_int) :: expected_layout ! ---------------------- rank 3 data_r3(1,:,:) = 0.06 data_r3(2,:,:) = 1.06 data_r3(3,:,:) = 2.06 tensor_r3 = fckit_tensor_real64(data_r3, fckit_tensor%layout_rowmajor()) expected_size = 3*3*3 expected_rank = 3 expected_layout = fckit_tensor%layout_rowmajor() ! check tensor info from c++ call check_tensor_double(tensor_r3%c_ptr(), expected_size, expected_rank, expected_layout) ! check internal data.. call check_tensor_double_layout_r3(tensor_r3%c_ptr(), data_r3) ! ---------------------- rank 4 data_r4(1,:,:,:) = 1.16 data_r4(2,:,:,:) = 2.26 data_r4(:,:,:,6) = 3.36 tensor_r4 = fckit_tensor_real64(data_r4) ! layout is colmajor (by default) expected_size = 2*4*5*6 expected_rank = 4 expected_layout = fckit_tensor%layout_colmajor() ! check tensor info from c++ call check_tensor_double(tensor_r4%c_ptr(), expected_size, expected_rank, expected_layout) ! check internal data.. call check_tensor_double_layout_r4(tensor_r4%c_ptr(), data_r4) #else #warning Test "test_tensor_double_interop" disabled #endif END_TEST TEST ( test_tensor_double_creation_from_cpp ) #if 1 use iso_c_binding, only : c_ptr, c_int, c_size_t use fckit_tensor_module, only : fckit_tensor_real64, fckit_tensor type(fckit_tensor_real64) :: tensor integer(c_int) :: tensor_shape_input(4) = (/ 4,2,3,4 /) integer(c_size_t), allocatable :: tensor_shape(:) integer(c_size_t) :: expected_size = 4*2*3*4 integer(c_size_t) :: expected_rank = 4 integer(c_size_t) :: expected_shape(4) = (/ 4,2,3,4 /) call tensor%reset_c_ptr(create_tensor_double_filled(tensor_shape_input, size(tensor_shape_input), fckit_tensor%layout_colmajor())) FCTEST_CHECK_EQUAL( tensor%size(), expected_size ) FCTEST_CHECK_EQUAL( tensor%rank(), expected_rank ) tensor_shape = tensor%shape() FCTEST_CHECK_EQUAL( tensor_shape(1), expected_shape(1) ) FCTEST_CHECK_EQUAL( tensor_shape(2), expected_shape(2) ) FCTEST_CHECK_EQUAL( tensor_shape(3), expected_shape(3) ) FCTEST_CHECK_EQUAL( tensor_shape(4), expected_shape(4) ) FCTEST_CHECK_EQUAL( tensor%layout(), fckit_tensor%layout_colmajor() ) ! deallocation deallocate(tensor_shape) call delete_tensor_double(tensor%c_ptr()) #else #warning Test "test_tensor_double_creation_from_cpp" disabled #endif END_TEST END_TESTSUITE fckit-0.14.3/src/tests/test_mpi.F900000664000175000017500000005131015202607540017121 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fctest.h" TESTSUITE( test_mpi ) TESTSUITE_INIT use fckit_module call fckit_main%init() END_TESTSUITE_INIT TESTSUITE_FINALIZE use fckit_module call fckit_main%final() END_TESTSUITE_FINALIZE TEST( test_default_comm ) use fckit_module use, intrinsic :: iso_c_binding implicit none write(0,*) "test_default_comm" write(0,*) "default size:", fckit_mpi%size() write(0,*) "default rank:", fckit_mpi%rank() END_TEST TEST( test_comm ) use fckit_module use, intrinsic :: iso_c_binding implicit none type(fckit_mpi_comm) :: comm write(0,*) "test_comm" comm = fckit_mpi_comm() write(0,*) "default size:", comm%size() write(0,*) "default rank:", comm%rank() comm = fckit_mpi_comm("world") write(0,*) "world size:", comm%size() write(0,*) "default world:", comm%rank() comm = fckit_mpi_comm("self") FCTEST_CHECK_EQUAL( comm%size(), 1 ) FCTEST_CHECK_EQUAL( comm%rank(), 0 ) END_TEST TEST( test_self_comm ) use fckit_module use, intrinsic :: iso_c_binding implicit none integer :: fcomm_self type(fckit_mpi_comm) :: comm1, comm2 comm1 = fckit_mpi_comm("self") fcomm_self = comm1%communicator() comm2 = fckit_mpi_comm(fcomm_self) FCTEST_CHECK_EQUAL( comm2%size(), 1 ) FCTEST_CHECK_EQUAL( comm2%rank(), 0 ) END_TEST TEST( test_add_comm ) use fckit_mpi_module use, intrinsic :: iso_c_binding implicit none integer :: fcomm_self type(fckit_mpi_comm) :: comm_self, comm2 comm_self = fckit_mpi_comm("self") fcomm_self = comm_self%communicator() call fckit_mpi_addComm("another_self",fcomm_self) comm2 = fckit_mpi_comm("another_self") FCTEST_CHECK_EQUAL( comm2%size(), 1 ) FCTEST_CHECK_EQUAL( comm2%rank(), 0 ) END_TEST TEST( test_set_comm_default ) use fckit_mpi_module use, intrinsic :: iso_c_binding implicit none type(fckit_mpi_comm) :: comm write(0,*) "test_set_comm_default" call fckit_mpi_setCommDefault("self") comm = fckit_mpi_comm() FCTEST_CHECK_EQUAL( comm%size(), 1 ) FCTEST_CHECK_EQUAL( comm%rank(), 0 ) END_TEST TEST( test_uninitialised ) use fckit_module use, intrinsic :: iso_c_binding type(fckit_mpi_comm) :: comm write(0,*) "test_uninitialised" FCTEST_CHECK_EQUAL( comm%size(), 1 ) FCTEST_CHECK_EQUAL( comm%rank(), 0 ) END_TEST TEST( test_allreduce ) use fckit_mpi_module use, intrinsic :: iso_c_binding implicit none type(fckit_mpi_comm) :: comm real(c_double) :: real64, res_real64, real64_r1(2), res_real64_r1(2) real(c_float) :: real32, res_real32, real32_r2(3,2), res_real32_r2(3,2) integer(c_int32_t) :: int32, res_int32, res_int32_r3(4,3,2), j integer(c_long) :: int64, res_int64, int64_r4(4,3,2,2), res_int64_r4(4,3,2,2), check_prod, check_sum FCKIT_SUPPRESS_UNUSED( real64_r1 ) FCKIT_SUPPRESS_UNUSED( res_real64_r1 ) FCKIT_SUPPRESS_UNUSED( res_int32_r3 ) FCKIT_SUPPRESS_UNUSED( res_real32_r2 ) FCKIT_SUPPRESS_UNUSED( real32_r2 ) write(0,*) "test_allreduce" comm = fckit_mpi_comm("world") real64 = 2 call comm%allreduce(real64,res_real64,fckit_mpi_sum()) FCTEST_CHECK_EQUAL( int(res_real64), 2*comm%size() ) real64 = comm%rank()+1 call comm%allreduce(real64,res_real64,fckit_mpi_max()) FCTEST_CHECK_EQUAL( int(res_real64), comm%size()) call comm%allreduce(real64,res_real64,fckit_mpi_min()) FCTEST_CHECK_EQUAL( int(res_real64), 1 ) check_prod = 1 check_sum = 0 do j=1,comm%size() check_prod = check_prod * j check_sum = check_sum + j enddo call comm%allreduce(real64,res_real64,fckit_mpi_prod()) FCTEST_CHECK_EQUAL( int(res_real64), int(check_prod) ) real32 = 3 call comm%allreduce(real32,res_real32,fckit_mpi_sum()) FCTEST_CHECK_EQUAL( int(res_real32), 3*comm%size() ) int32 = 4 call comm%allreduce(int32,res_int32,fckit_mpi_sum()) FCTEST_CHECK_EQUAL( int(res_int32), 4*comm%size() ) int64 = 5 call comm%allreduce(int64,res_int64,fckit_mpi_sum()) FCTEST_CHECK_EQUAL( int(res_int64), 5*comm%size() ) int64_r4(1,1,1,1) = 2 int64_r4(2,3,1,2) = comm%rank()+1 int64_r4(3,1,2,1) = comm%size() call comm%allreduce(int64_r4,res_int64_r4,fckit_mpi_prod()) FCTEST_CHECK_EQUAL(res_int64_r4(2,3,1,2),check_prod) call comm%allreduce(int64_r4,res_int64_r4,fckit_mpi_sum()) FCTEST_CHECK_EQUAL(res_int64_r4(2,3,1,2),check_sum) FCTEST_CHECK_EQUAL(res_int64_r4(3,1,2,1),int(comm%size()*comm%size(),c_long)) FCTEST_CHECK_EQUAL(res_int64_r4(1,1,1,1),int(comm%size()*2,c_long)) call comm%allreduce(int64_r4,res_int64_r4,fckit_mpi_max()) FCTEST_CHECK_EQUAL(res_int64_r4(2,3,1,2),int(comm%size(),c_long)) FCTEST_CHECK_EQUAL(res_int64_r4(3,1,2,1),int(comm%size(),c_long)) FCTEST_CHECK_EQUAL(res_int64_r4(1,1,1,1),int(2,c_long)) call comm%allreduce(int64_r4,res_int64_r4,fckit_mpi_min()) FCTEST_CHECK_EQUAL(res_int64_r4(2,3,1,2),int(1,c_long)) FCTEST_CHECK_EQUAL(res_int64_r4(3,1,2,1),int(comm%size(),c_long)) FCTEST_CHECK_EQUAL(res_int64_r4(1,1,1,1),int(2,c_long)) END_TEST TEST( test_allreduce_inplace ) use fckit_mpi_module use, intrinsic :: iso_c_binding implicit none type(fckit_mpi_comm) :: comm real(c_double) :: real64, real64_r1(2) real(c_float) :: real32, real32_r2(3,2) integer(c_int32_t) :: int32, int32_r3(4,3,2), j integer(c_long) :: int64, int64_r4(4,3,2,2), check_prod, check_sum FCKIT_SUPPRESS_UNUSED( real64_r1 ) FCKIT_SUPPRESS_UNUSED( int32_r3 ) FCKIT_SUPPRESS_UNUSED( real32_r2 ) write(0,*) "test_allreduce_inplace" comm = fckit_mpi_comm("world") real64 = 2 call comm%allreduce(real64,fckit_mpi_sum()) FCTEST_CHECK_EQUAL( int(real64), 2*comm%size() ) real64 = comm%rank()+1 call comm%allreduce(real64,fckit_mpi_max()) FCTEST_CHECK_EQUAL( int(real64), comm%size()) real64 = comm%rank()+1 call comm%allreduce(real64,fckit_mpi_min()) FCTEST_CHECK_EQUAL( int(real64), 1 ) check_prod = 1 check_sum = 0 do j=1,comm%size() check_prod = check_prod * j check_sum = check_sum + j enddo real64 = comm%rank()+1 call comm%allreduce(real64,fckit_mpi_prod()) FCTEST_CHECK_EQUAL( int(real64), int(check_prod) ) real32 = 3 call comm%allreduce(real32,fckit_mpi_sum()) FCTEST_CHECK_EQUAL( int(real32), 3*comm%size() ) int32 = 4 call comm%allreduce(int32,fckit_mpi_sum()) FCTEST_CHECK_EQUAL( int(int32), 4*comm%size() ) int64 = 5 call comm%allreduce(int64,fckit_mpi_sum()) FCTEST_CHECK_EQUAL( int(int64), 5*comm%size() ) int64_r4(1,1,1,1) = 2 int64_r4(2,3,1,2) = comm%rank()+1 int64_r4(3,1,2,1) = comm%size() call comm%allreduce(int64_r4,fckit_mpi_prod()) FCTEST_CHECK_EQUAL(int64_r4(2,3,1,2),check_prod) int64_r4(1,1,1,1) = 2 int64_r4(2,3,1,2) = comm%rank()+1 int64_r4(3,1,2,1) = comm%size() call comm%allreduce(int64_r4,fckit_mpi_sum()) FCTEST_CHECK_EQUAL(int64_r4(2,3,1,2),check_sum) FCTEST_CHECK_EQUAL(int64_r4(3,1,2,1),int(comm%size()*comm%size(),c_long)) FCTEST_CHECK_EQUAL(int64_r4(1,1,1,1),int(comm%size()*2,c_long)) int64_r4(1,1,1,1) = 2 int64_r4(2,3,1,2) = comm%rank()+1 int64_r4(3,1,2,1) = comm%size() call comm%allreduce(int64_r4,fckit_mpi_max()) FCTEST_CHECK_EQUAL(int64_r4(2,3,1,2),int(comm%size(),c_long)) FCTEST_CHECK_EQUAL(int64_r4(3,1,2,1),int(comm%size(),c_long)) FCTEST_CHECK_EQUAL(int64_r4(1,1,1,1),int(2,c_long)) int64_r4(1,1,1,1) = 2 int64_r4(2,3,1,2) = comm%rank()+1 int64_r4(3,1,2,1) = comm%size() call comm%allreduce(int64_r4,fckit_mpi_min()) FCTEST_CHECK_EQUAL(int64_r4(2,3,1,2),int(1,c_long)) FCTEST_CHECK_EQUAL(int64_r4(3,1,2,1),int(comm%size(),c_long)) FCTEST_CHECK_EQUAL(int64_r4(1,1,1,1),int(2,c_long)) END_TEST TEST( test_allgather ) use fckit_module use, intrinsic ::iso_c_binding implicit none type(fckit_mpi_comm) :: comm real(c_double) :: real64, real64_r1(2) real(c_double), allocatable :: res_real64(:), res_real64_r1(:) real(c_double), allocatable :: real64v_r1(:), res_real64v_r1(:) real(c_float) :: real32, real32_r1(2) real(c_float), allocatable :: res_real32(:), res_real32_r1(:) real(c_float), allocatable :: real32v_r1(:), res_real32v_r1(:) integer(c_int32_t) :: int32, int32_r1(2), j integer(c_int32_t), allocatable :: res_int32(:), res_int32_r1(:) integer(c_int32_t), allocatable :: int32v_r1(:), res_int32v_r1(:) integer(c_long) :: int64, int64_r1(2) integer(c_long), allocatable :: res_int64(:), res_int64_r1(:) integer(c_long), allocatable :: int64v_r1(:), res_int64v_r1(:) integer, allocatable :: recvcounts(:), displs(:) write(0,*) "test_allgather" comm = fckit_mpi_comm("world") int32 = 2 allocate(res_int32(comm%size())) call comm%allgather(int32,res_int32) FCTEST_CHECK_EQUAL(minval(res_int32),int32) FCTEST_CHECK_EQUAL(maxval(res_int32),int32) deallocate(res_int32) int64 = 3 allocate(res_int64(comm%size())) call comm%allgather(int64,res_int64) FCTEST_CHECK_EQUAL(minval(res_int64),int64) FCTEST_CHECK_EQUAL(maxval(res_int64),int64) deallocate(res_int64) real32 = 4 allocate(res_real32(comm%size())) call comm%allgather(real32,res_real32) FCTEST_CHECK_EQUAL(minval(res_real32),real32) FCTEST_CHECK_EQUAL(maxval(res_real32),real32) deallocate(res_real32) real64 = 5 allocate(res_real64(comm%size())) call comm%allgather(real64,res_real64) FCTEST_CHECK_EQUAL(minval(res_real64),real64) FCTEST_CHECK_EQUAL(maxval(res_real64),real64) deallocate(res_real64) int32_r1 = (/ 2,3 /) allocate(res_int32_r1(size(int32_r1)*comm%size())) call comm%allgather(int32_r1,res_int32_r1,size(int32_r1)) FCTEST_CHECK_EQUAL(minval(res_int32_r1),minval(int32_r1)) FCTEST_CHECK_EQUAL(maxval(res_int32_r1),maxval(int32_r1)) deallocate(res_int32_r1) int64_r1 = (/ 4,5 /) allocate(res_int64_r1(size(int64_r1)*comm%size())) call comm%allgather(int64_r1,res_int64_r1,size(int64_r1)) FCTEST_CHECK_EQUAL(minval(res_int64_r1),minval(int64_r1)) FCTEST_CHECK_EQUAL(maxval(res_int64_r1),maxval(int64_r1)) deallocate(res_int64_r1) real32_r1 = (/ 6,7 /) allocate(res_real32_r1(size(real32_r1)*comm%size())) call comm%allgather(real32_r1,res_real32_r1,size(real32_r1)) FCTEST_CHECK_EQUAL(minval(res_real32_r1),minval(real32_r1)) FCTEST_CHECK_EQUAL(maxval(res_real32_r1),maxval(real32_r1)) deallocate(res_real32_r1) real64_r1 = (/ 8,9 /) allocate(res_real64_r1(size(real64_r1)*comm%size())) call comm%allgather(real64_r1,res_real64_r1,size(real64_r1)) FCTEST_CHECK_EQUAL(minval(res_real64_r1),minval(real64_r1)) FCTEST_CHECK_EQUAL(maxval(res_real64_r1),maxval(real64_r1)) deallocate(res_real64_r1) allocate(recvcounts(comm%size()),displs(comm%size())) allocate(int32v_r1(comm%rank()+1)) int32v_r1 = comm%rank() recvcounts(1) = 1 displs(1) = 0 do j = 2,comm%size() recvcounts(j) = j displs(j) = displs(j-1)+recvcounts(j-1) enddo allocate(res_int32v_r1(sum(recvcounts))) call comm%allgather(int32v_r1,res_int32v_r1,size(int32v_r1),recvcounts,displs) FCTEST_CHECK_EQUAL(minval(res_int32v_r1),0) FCTEST_CHECK_EQUAL(maxval(res_int32v_r1),comm%size()-1) deallocate(int32v_r1,res_int32v_r1) allocate(int64v_r1(comm%size()-comm%rank())) int64v_r1 = comm%rank() recvcounts(1) = comm%size() displs(1) = 0 do j = 2,comm%size() recvcounts(j) = comm%size() - j + 1 displs(j) = displs(j-1)+recvcounts(j-1) enddo allocate(res_int64v_r1(sum(recvcounts))) call comm%allgather(int64v_r1,res_int64v_r1,size(int64v_r1),recvcounts,displs) FCTEST_CHECK_EQUAL(int(minval(res_int64v_r1)),0) FCTEST_CHECK_EQUAL(int(maxval(res_int64v_r1)),comm%size()-1) deallocate(int64v_r1,res_int64v_r1) allocate(real32v_r1(comm%rank()+1)) real32v_r1 = comm%rank() recvcounts(1) = 1 displs(1) = 0 do j = 2,comm%size() recvcounts(j) = j displs(j) = displs(j-1)+recvcounts(j-1) enddo allocate(res_real32v_r1(sum(recvcounts))) call comm%allgather(real32v_r1,res_real32v_r1,size(real32v_r1),recvcounts,displs) FCTEST_CHECK_EQUAL(minval(res_real32v_r1),real(0,c_float)) FCTEST_CHECK_EQUAL(maxval(res_real32v_r1),real(comm%size()-1,c_float)) deallocate(real32v_r1,res_real32v_r1) allocate(real64v_r1(comm%size()-comm%rank())) real64v_r1 = comm%rank() recvcounts(1) = comm%size() displs(1) = 0 do j = 2,comm%size() recvcounts(j) = comm%size() - j + 1 displs(j) = displs(j-1)+recvcounts(j-1) enddo allocate(res_real64v_r1(sum(recvcounts))) call comm%allgather(real64v_r1,res_real64v_r1,size(real64v_r1),recvcounts,displs) FCTEST_CHECK_EQUAL(minval(res_real64v_r1),real(0,c_double)) FCTEST_CHECK_EQUAL(maxval(res_real64v_r1),real(comm%size()-1,c_double)) deallocate(real64v_r1,res_real64v_r1) deallocate(recvcounts,displs) END_TEST TEST( test_broadcast ) use fckit_mpi_module use, intrinsic :: iso_c_binding implicit none type(fckit_mpi_comm) :: comm real(c_double) :: real64, real64_r1(2) real(c_float) :: real32, real32_r2(3,2) integer(c_int32_t) :: int32, int32_r3(4,3,2) integer(c_long) :: int64, int64_r4(4,3,2,2) logical :: logical_r1(4) character(len=30) :: string_r0 FCKIT_SUPPRESS_UNUSED( real64_r1 ) FCKIT_SUPPRESS_UNUSED( int64 ) FCKIT_SUPPRESS_UNUSED( real32_r2 ) write(0,*) "test_broadcast" comm = fckit_mpi_comm("world") if(comm%rank()==0) real64 = 0.1_c_double call comm%broadcast(real64,root=0) FCTEST_CHECK_CLOSE(real64, 0.1_c_double,1.e-9_c_double) if(comm%rank()==0) real32 = 0.2_c_float call comm%broadcast(real32,root=0) FCTEST_CHECK_CLOSE(real32, 0.2_c_float,1.e-5_c_float) if(comm%rank()==comm%size()-1) int32 = 3 call comm%broadcast(int32,root=comm%size()-1) FCTEST_CHECK_EQUAL(int32, 3) if(comm%rank()==0) int64_r4(2,2,1,2) = 1_c_long call comm%broadcast(int64_r4,root=0) FCTEST_CHECK_EQUAL(int64_r4(2,2,1,2), 1_c_long) if(comm%rank()==0) int32_r3(1,3,2) = 2 call comm%broadcast(int32_r3,root=0) FCTEST_CHECK_EQUAL(int32_r3(1,3,2), 2_c_int32_t) if(comm%rank()==comm%size()-1) int32_r3(2,1,1) = 3 call comm%broadcast(int32_r3,root=comm%size()-1) FCTEST_CHECK_EQUAL(int32_r3(2,1,1), 3) if(comm%rank()==comm%size()-1) logical_r1(2) = .true. call comm%broadcast(logical_r1,root=comm%size()-1) FCTEST_CHECK_EQUAL(logical_r1(2), .true.) if(comm%rank()==comm%size()-1) string_r0 = "path/filename" call comm%broadcast(string_r0,root=comm%size()-1) FCTEST_CHECK_EQUAL(string_r0, "path/filename") END_TEST TEST( test_nonblocking_send_receive ) use fckit_mpi_module use, intrinsic :: iso_c_binding implicit none type(fckit_mpi_comm) :: comm integer :: sendreq, recvreq type(fckit_mpi_status) :: status integer :: tag=1 real(c_double) :: send_real64, recv_real64 write(0,*) "test_nonblocking_send_receive" comm = fckit_mpi_comm("world") send_real64 = 0._c_double if( comm%rank()==comm%size()-1) then recvreq = comm%ireceive(recv_real64,0,tag) write(0,*) "receive-request:",recvreq endif if(comm%rank()==0) then send_real64 = 0.1_c_double sendreq = comm%isend(send_real64,comm%size()-1,tag) write(0,*) "send-request:",sendreq endif if( comm%rank()==comm%size()-1) then call comm%wait(recvreq,status) FCTEST_CHECK_CLOSE(recv_real64, 0.1_c_double,1.e-9_c_double) endif if(comm%rank()==0) then call comm%wait(sendreq,status) endif ! FCTEST_CHECK_EQUAL(status%source(), 0) ! FCTEST_CHECK_EQUAL(status%tag(), tag) ! FCTEST_CHECK_EQUAL(status%error(), 0) END_TEST TEST( test_blocking_send_receive ) use fckit_mpi_module use, intrinsic :: iso_c_binding implicit none type(fckit_mpi_comm) :: comm type(fckit_mpi_status) :: status integer :: tag=99 real(c_double) :: send_real64, recv_real64 write(0,*) "test_blocking_send_receive" comm = fckit_mpi_comm("world") send_real64 = 0._c_double if(comm%rank()==0) then send_real64 = 0.1_c_double call comm%send(send_real64,comm%size()-1,tag) send_real64 = 0.2_c_double call comm%send(send_real64,comm%size()-1,tag+1) endif if( comm%rank()==comm%size()-1) then call comm%receive(recv_real64,0,tag,status) FCTEST_CHECK_CLOSE(recv_real64, 0.1_c_double,1.e-9_c_double) FCTEST_CHECK_EQUAL(status%source(), 0) FCTEST_CHECK_EQUAL(status%tag(), tag) FCTEST_CHECK_EQUAL(status%error(), 0) call comm%receive(recv_real64,0,tag=comm%anytag(),status=status) FCTEST_CHECK_EQUAL(status%tag(), tag+1) FCTEST_CHECK_CLOSE(recv_real64, 0.2_c_double,1.e-9_c_double) endif END_TEST TEST( test_blocking_send_receive_real64_rank1 ) use fckit_mpi_module use, intrinsic :: iso_c_binding implicit none type(fckit_mpi_comm) :: comm type(fckit_mpi_status) :: status integer :: tag=99 real(c_double) :: send_real64(2), recv_real64(2) write(0,*) "test_blocking_send_receive_rank1" comm = fckit_mpi_comm("world") send_real64 = [ 0._c_double , 0._c_double ] if(comm%rank()==0) then send_real64 = [ 0.1_c_double , 0.1_c_double ] call comm%send(send_real64,comm%size()-1,tag) send_real64 = [ 0.2_c_double , 0.2_c_double ] call comm%send(send_real64,comm%size()-1,tag+1) endif if( comm%rank()==comm%size()-1) then call comm%receive(recv_real64,0,tag,status) FCTEST_CHECK_CLOSE(recv_real64, ( [0.1_c_double,0.1_c_double] ),1.e-9_c_double) FCTEST_CHECK_EQUAL(status%source(), 0) FCTEST_CHECK_EQUAL(status%tag(), tag) FCTEST_CHECK_EQUAL(status%error(), 0) call comm%receive(recv_real64,0,tag=comm%anytag(),status=status) FCTEST_CHECK_EQUAL(status%tag(), tag+1) FCTEST_CHECK_CLOSE(recv_real64, ( [0.2_c_double,0.2_c_double] ),1.e-9_c_double) endif END_TEST TEST( test_blocking_send_receive_int32_rank1 ) use fckit_mpi_module use, intrinsic :: iso_c_binding implicit none type(fckit_mpi_comm) :: comm type(fckit_mpi_status) :: status integer :: tag=99 integer(c_int32_t) :: send(2), recv(2) write(0,*) "test_blocking_send_receive_int32_rank1" comm = fckit_mpi_comm("world") send = [ 0_c_int32_t , 0_c_int32_t ] if(comm%rank()==0) then send = [ 1_c_int32_t , 2_c_int32_t ] call comm%send(send,comm%size()-1,tag) send = [ 3_c_int32_t , 4_c_int32_t ] call comm%send(send,comm%size()-1,tag+1) endif if( comm%rank()==comm%size()-1) then call comm%receive(recv,0,tag,status) FCTEST_CHECK_EQUAL(recv, ( [1_c_int32_t,2_c_int32_t] ) ) FCTEST_CHECK_EQUAL(status%source(), 0) FCTEST_CHECK_EQUAL(status%tag(), tag) FCTEST_CHECK_EQUAL(status%error(), 0) call comm%receive(recv,0,tag=comm%anytag(),status=status) FCTEST_CHECK_EQUAL(status%tag(), tag+1) FCTEST_CHECK_EQUAL(recv, ( [3_c_int32_t,4_c_int32_t] ) ) endif END_TEST TEST( test_blocking_send_receive_int64_rank1 ) use fckit_mpi_module use, intrinsic :: iso_c_binding implicit none type(fckit_mpi_comm) :: comm type(fckit_mpi_status) :: status integer :: tag=99 integer(c_int64_t) :: send(2), recv(2) write(0,*) "test_blocking_send_receive_int64_rank1" comm = fckit_mpi_comm("world") send = [ 0_c_int64_t , 0_c_int64_t ] if(comm%rank()==0) then send = [ 1_c_int64_t , 2_c_int64_t ] call comm%send(send,comm%size()-1,tag) send = [ 3_c_int64_t , 4_c_int64_t ] call comm%send(send,comm%size()-1,tag+1) endif if( comm%rank()==comm%size()-1) then call comm%receive(recv,0,tag,status) FCTEST_CHECK_EQUAL(recv, ( [1_c_int64_t,2_c_int64_t] ) ) FCTEST_CHECK_EQUAL(status%source(), 0) FCTEST_CHECK_EQUAL(status%tag(), tag) FCTEST_CHECK_EQUAL(status%error(), 0) call comm%receive(recv,0,tag=comm%anytag(),status=status) FCTEST_CHECK_EQUAL(status%tag(), tag+1) FCTEST_CHECK_EQUAL(recv, ( [3_c_int64_t,4_c_int64_t] ) ) endif END_TEST TEST( test_split_comm_delete ) use fckit_mpi_module use, intrinsic :: iso_c_binding implicit none type(fckit_mpi_comm) :: world ! a handle for the world comm type(fckit_mpi_comm) :: split ! a handle for the split comm integer :: i world = fckit_mpi_comm("world") if( mod(world%size(),2) == 0 ) then do i=1,10 split = world%split( merge(1,2,world%rank() #include #include #include static int destructor_called = 0; static int destructor_called_after_scope = 0; static int scope_ended = 0; extern "C" { void fckit_write_to_fortran_unit( int unit, const char* msg ); int fckit_fortranunit_stdout(); int fckit_fortranunit_stderr(); } class Object { public: Object( int i ) : i_( i ) { std::stringstream out; out << "constructing Object " << i_; fckit_write_to_fortran_unit( fckit_fortranunit_stderr(), out.str().c_str() ); } ~Object() { std::stringstream out; out << "destructing Object " << i_; fckit_write_to_fortran_unit( fckit_fortranunit_stderr(), out.str().c_str() ); destructor_called += 1; if ( scope_ended ) destructor_called_after_scope += 1; } int id() const { return i_; } private: int i_; }; extern "C" { Object* new_Object( int i ) { return new Object( i ); } void delete_Object( Object* p ) { delete p; } int Object__id( const Object* p ) { return p->id(); } int cxx_destructor_called() { return destructor_called; } int cxx_destructor_called_after_scope() { return destructor_called_after_scope; } void cxx_reset_counters() { destructor_called = 0; destructor_called_after_scope = 0; scope_ended = 0; } void cxx_end_scope() { scope_ended = 1; } } fckit-0.14.3/src/tests/test_array.F900000664000175000017500000000220415202607540017450 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fctest.h" TESTSUITE( array ) TEST( test_array_view1d ) use fckit_array_module, only: array_view1d use, intrinsic :: iso_c_binding integer(c_int32_t), target :: array_int32_r2(20,10) integer(c_int32_t), pointer :: view(:) write(0,*) "test_array_view1d" view => array_view1d(array_int32_r2) FCTEST_CHECK_EQUAL( size(view), 200 ) END_TEST TEST( test_array_stride ) use fckit_array_module, only: array_stride, array_strides use, intrinsic :: iso_c_binding integer(c_int32_t) :: array_int32_r2(20,10) write(0,*) "test_array_stride" FCTEST_CHECK_EQUAL( array_stride(array_int32_r2,1), 1 ) FCTEST_CHECK_EQUAL( array_stride(array_int32_r2,2), 20 ) FCTEST_CHECK_EQUAL( array_strides(array_int32_r2), ([1,20]) ) END_TEST END_TESTSUITE fckit-0.14.3/src/tests/test_abort.F900000664000175000017500000001006715202607540017447 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fctest.h" #define TEST_ABORT 0 subroutine abort_func_0() use fckit_module type(fckit_mpi_comm) :: mpi call fckit_log%info("custom_abort 0",flush=.true.) mpi = fckit_mpi_comm("world") call mpi%abort() end subroutine subroutine abort_func_1(msg) use fckit_module type(fckit_mpi_comm) :: mpi character(len=*), intent(in) :: msg character(len=1024) :: string write(string,*) "custom abort 1, msg = ", msg call fckit_log%info(string,flush=.true.) mpi = fckit_mpi_comm("world") call mpi%abort() end subroutine subroutine abort_func_2(msg,file,line) use fckit_module type(fckit_mpi_comm) :: mpi character(len=*), intent(in) :: msg character(len=*), intent(in) :: file integer, intent(in) :: line character(len=1024) :: string write(string,*) "custom abort 2, msg = ", msg, ", file = ",file, ", line = ",line call fckit_log%info(string,flush=.true.) mpi = fckit_mpi_comm("world") call mpi%abort() end subroutine module fckit_test_abort_fx public contains subroutine abort_wrapper() use fckit_module if( fckit_exception%location%is_set() ) then call abort_func_2( fckit_exception%what(), fckit_exception%location%file(), fckit_exception%location%line() ) else call abort_func_1( fckit_exception%what() ) endif end subroutine subroutine sig_handler(signum) bind(c) use, intrinsic :: iso_c_binding, only : c_int32_t use fckit_module integer(c_int32_t), value, intent(in) :: signum character(len=1024) :: string write(string,*) "signal handler intercepted signal ",signum call fckit_log%info(string,flush=.true.) end subroutine end module TESTSUITE( fckit_test_abort ) TESTSUITE_INIT use fckit_module call fckit_main%init() END_TESTSUITE_INIT TESTSUITE_FINALIZE use fckit_module call fckit_main%final() END_TESTSUITE_FINALIZE TEST( test_signal ) use fckit_module use fckit_test_abort_fx implicit none procedure(fckit_signal_handler), pointer:: signal_handler signal_handler => sig_handler #if TEST_ABORT ! call fckit_signal%restore_handlers() ! call fckit_signal%raise(fckit_signal%SIGABRT()) #endif call fckit_signal%set_handler(fckit_signal%SIGABRT(),signal_handler) call fckit_signal%raise(fckit_signal%SIGABRT()) END_TEST TEST( test_abort_1 ) use fckit_module implicit none interface subroutine abort_func_0() end subroutine end interface procedure(fckit_exception_handler), pointer:: exception_handler exception_handler => abort_func_0 call fckit_exception%set_handler( exception_handler ) #if TEST_ABORT ! call fckit_exception%abort() #endif END_TEST TEST( test_abort_2 ) use fckit_module use fckit_test_abort_fx implicit none procedure(fckit_exception_handler), pointer:: exception_handler exception_handler => abort_wrapper call fckit_exception%set_handler( exception_handler ) # if TEST_ABORT ! call fckit_exception%abort("test_abort_2") #endif END_TEST TEST( test_abort_3 ) use fckit_module use fckit_test_abort_fx implicit none procedure(fckit_exception_handler), pointer:: exception_handler exception_handler => abort_wrapper call fckit_exception%set_handler( exception_handler ) #if TEST_ABORT ! call fckit_exception%abort("test_abort_3","test_abort.F90",__LINE__) #endif END_TEST TEST( test_throw ) use fckit_module implicit none #if TEST_ABORT ! call fckit_exception%throw("Exception: test throw","test_abort.F90",__LINE__) #endif END_TEST TEST( test_interrupt ) use fckit_module implicit none #if TEST_ABORT call fckit_log%info("Please write CTRL+C to interrupt",flush=.true.) call sleep(5) #endif END_TEST TEST( test_summary ) write(0,*) "Change inside this file (test_abort.F90) the definition TEST_ABORT to 1, and expect tests to fail" END_TEST END_TESTSUITE fckit-0.14.3/src/tests/test_owned_object.F900000664000175000017500000001261515202607540021003 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! 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. ! This File contains Unit Tests for testing the ! C++ / Fortran Interfaces to the State Datastructure ! @author Willem Deconinck #include "fckit/fctest.h" module test_Grid_module use fckit_owned_object_module, only: fckit_owned_object use, intrinsic :: iso_c_binding, only : c_ptr implicit none private :: fckit_owned_object private :: c_ptr public :: test_Grid public :: test_StructuredGrid private interface function new_Object(i) bind(c,name="new_Object") use, intrinsic :: iso_c_binding, only : c_ptr, c_int32_t type(c_ptr) :: new_Object integer(c_int32_t), value :: i end function subroutine delete_Object(cptr) bind(c,name="delete_Object") use, intrinsic :: iso_c_binding, only : c_ptr type(c_ptr), value :: cptr end subroutine end interface !------------------------------------------------------------------------------ TYPE, extends(fckit_owned_object) :: test_Grid ! Purpose : ! ------- ! *test_Grid* : Object Grid specifications for Grids ! Methods : ! ------- ! Author : ! ------ ! 9-Oct-2014 Willem Deconinck *ECMWF* !------------------------------------------------------------------------------ contains #if FCKIT_FINAL_NOT_INHERITING final :: test_Grid__final_auto #endif END TYPE test_Grid interface test_Grid module procedure test_Grid__ctor_id module procedure test_Grid__ctor_cptr end interface !------------------------------------------------------------------------------ TYPE, extends(test_Grid) :: test_StructuredGrid ! Purpose : ! ------- ! *test_StructuredGrid* : Object Grid specifications for Reduced Grids ! Methods : ! ------- ! Author : ! ------ ! 9-Oct-2014 Willem Deconinck *ECMWF* !------------------------------------------------------------------------------ contains #if FCKIT_FINAL_NOT_INHERITING final :: test_StructuredGrid__final_auto #endif END TYPE test_StructuredGrid interface test_StructuredGrid module procedure test_StructuredGrid__ctor_id end interface !------------------------------------------------------------------------------ !======================================================== contains !======================================================== ! ----------------------------------------------------------------------------- ! Destructor #if FCKIT_FINAL_NOT_INHERITING impure elemental subroutine test_Grid__final_auto(this) type(test_Grid), intent(inout) :: this #if FCKIT_FINAL_NOT_PROPAGATING call this%final() #endif FCKIT_SUPPRESS_UNUSED( this ) end subroutine impure elemental subroutine test_StructuredGrid__final_auto(this) type(test_StructuredGrid), intent(inout) :: this #if FCKIT_FINAL_NOT_PROPAGATING call this%final() #endif FCKIT_SUPPRESS_UNUSED( this ) end subroutine #endif ! ----------------------------------------------------------------------------- ! Constructors function test_Grid__ctor_id(identifier) result(this) use fckit_c_interop_module, only: c_str type(test_Grid) :: this integer, intent(in) :: identifier call this%reset_c_ptr( new_Object(identifier) ) call this%return() end function function test_Grid__ctor_cptr(cptr) result(this) use fckit_c_interop_module, only: c_str type(test_Grid) :: this type(c_ptr), intent(in) :: cptr call this%reset_c_ptr( cptr ) call this%return() end function ! ----------------------------------------------------------------------------- function test_StructuredGrid__ctor_id(identifier) result(this) use fckit_c_interop_module, only: c_str type(test_StructuredGrid) :: this integer, intent(in) :: identifier call this%reset_c_ptr( new_Object(identifier) ) call this%return() end function function test_StructuredGrid__ctor_cptr(cptr) result(this) use fckit_c_interop_module, only: c_str type(test_StructuredGrid) :: this type(c_ptr), intent(in) :: cptr call this%reset_c_ptr( cptr ) call this%return() end function ! ---------------------------------------------------------------------------------------- end module test_grid_module module fcta_FunctionSpace_fxt use, intrinsic :: iso_c_binding implicit none contains end module ! ----------------------------------------------------------------------------- TESTSUITE_WITH_FIXTURE(fcta_FunctionSpace,fcta_FunctionSpace_fxt) ! ----------------------------------------------------------------------------- TESTSUITE_INIT use fckit_module, only : fckit_main call fckit_main%initialise() END_TESTSUITE_INIT ! ----------------------------------------------------------------------------- TESTSUITE_FINALIZE use fckit_module, only : fckit_main call fckit_main%finalise() END_TESTSUITE_FINALIZE ! ----------------------------------------------------------------------------- TEST( test_nodescolumns ) use test_grid_module #if 1 type(test_Grid) :: grid grid = test_StructuredGrid(24) FCTEST_CHECK_EQUAL( grid%owners(), 1 ) call grid%final() #else #warning test test_nodescolumns disabled #endif END_TEST ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- END_TESTSUITE fckit-0.14.3/src/tests/test_shared_ptr.F900000664000175000017500000006667615202607540020514 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fctest.h" ! ----------------------------------------------------------------------------- module fcta_shared_ptr_f_fxt ! use fckit_object_module use fckit_final_module use fckit_shared_ptr_module use fckit_shared_object_module ! use fckit_c_interop_module use fctest implicit none integer, SAVE :: final_called = 0 integer, SAVE :: final_called_after_scope = 0 logical, SAVE :: scope_ended = .false. logical, SAVE :: deallocate_called = .false. ! ----------------------------------------------------------------------------- ! Unsafe because final is not guaranteed type :: ObjectFortranUnsafe integer :: id = -1 !! Data of Object (could be anything, like allocatable pointers) contains #if FCKIT_HAVE_FINAL final :: ObjectFortranUnsafe_final #endif endtype ! Safer because even if auto-final is not guaranteed, a manual final may finalise type, extends(fckit_final) :: ObjectFortranSafer integer :: id = -1 !! Data of Object (could be anything, like allocatable pointers) contains procedure :: final => ObjectFortranSafer_final !! Destructor of the data (e.g. if deallocations need to happen) endtype ! ----------------------------------------------------------------------------- interface function new_Object(i) bind(c,name="new_Object") use, intrinsic :: iso_c_binding, only : c_ptr, c_int32_t type(c_ptr) :: new_Object integer(c_int32_t), value :: i end function subroutine delete_Object(cptr) bind(c,name="delete_Object") use, intrinsic :: iso_c_binding, only : c_ptr type(c_ptr), value :: cptr end subroutine function Object__id(this) bind(c,name="Object__id") use, intrinsic :: iso_c_binding, only : c_ptr, c_int32_t type(c_ptr), value :: this integer(c_int32_t) :: Object__id end function function cxx_destructor_called() bind(c,name="cxx_destructor_called") use, intrinsic :: iso_c_binding, only : c_int32_t integer(c_int32_t) :: cxx_destructor_called end function function cxx_destructor_called_after_scope() bind(c,name="cxx_destructor_called_after_scope") use, intrinsic :: iso_c_binding, only : c_int32_t integer(c_int32_t) :: cxx_destructor_called_after_scope end function subroutine cxx_reset_counters() bind(c,name="cxx_reset_counters") end subroutine subroutine cxx_end_scope() bind(c,name="cxx_end_scope") end subroutine end interface type, extends(fckit_shared_object) :: ObjectCXX contains ! public : procedure :: id => ObjectCXX_id #if FCKIT_FINAL_NOT_INHERITING final :: ObjectCXX_final_auto #endif end type interface ObjectCXX module procedure ObjectCXX_constructor end interface ! ----------------------------------------------------------------------------- contains ! ----------------------------------------------------------------------------- subroutine reset_counters() deallocate_called = .false. final_called = 0 final_called_after_scope = 0 scope_ended = .false. call cxx_reset_counters() end subroutine subroutine end_scope() scope_ended = .true. call cxx_end_scope() end subroutine function ObjectCXX_constructor(id) result(this) type(ObjectCXX) :: this integer :: id call this%reset_c_ptr( new_Object(id) , fckit_c_deleter(delete_Object) ) FCTEST_CHECK_EQUAL( this%owners(), 1 ) call this%return() end function function ObjectCXX_id(this) result(id) class(ObjectCXX) :: this integer :: id id = Object__id( this%CPTR_PGIBUG_B ) end function FCKIT_FINAL subroutine ObjectCXX_final_auto(this) type(ObjectCXX), intent(inout) :: this write(0,*) "ObjectCXX_final_auto" #if FCKIT_FINAL_NOT_PROPAGATING call this%final() #endif FCKIT_SUPPRESS_UNUSED( this ) end subroutine subroutine ObjectFortranSafer_final(this) class(ObjectFortranSafer), intent(inout) :: this write(0,'(A,I0)') "ObjectFortranSafer_final id",this%id this%id = 0 final_called = final_called + 1 if( scope_ended ) final_called_after_scope = final_called_after_scope+1 end subroutine FCKIT_FINAL subroutine ObjectFortranUnSafe_final(this) type(ObjectFortranUnSafe), intent(inout) :: this write(0,'(A,I0)') "ObjectFortranUnSafe_final id",this%id this%id = 0 final_called = final_called + 1 if( scope_ended ) final_called_after_scope = final_called_after_scope+1 end subroutine ! ----------------------------------------------------------------------------- end module fcta_shared_ptr_f_fxt ! ----------------------------------------------------------------------------- TESTSUITE_WITH_FIXTURE(fckit_test_shared_ptr_f,fcta_shared_ptr_f_fxt) ! ----------------------------------------------------------------------------- TESTSUITE_INIT END_TESTSUITE_INIT ! ----------------------------------------------------------------------------- TESTSUITE_FINALIZE END_TESTSUITE_FINALIZE ! ----------------------------------------------------------------------------- function create_ObjectFortranSafer(id) result(this) type(fckit_shared_ptr) :: this integer :: id class(ObjectFortranSafer), pointer :: ptr write(0,'(A,I0)') "Constructing ObjectFortranSafer, id = ",id allocate( ObjectFortranSafer::ptr ) ptr%id = id write(0,'(A)') "----> this = fckit_make_shared( obj_ptr )" !this = fckit_make_shared( ptr ) call this%share( ptr ) write(0,'(A)') "<---- this = fckit_make_shared( obj_ptr )" FCTEST_CHECK_EQUAL( this%owners(), 1 ) call this%return() end function subroutine test_shared_ptr_safer( final_auto ) logical :: final_auto type(fckit_shared_ptr) :: obj1 class(ObjectFortranSafer), pointer :: obj2_ptr => null() type(fckit_shared_ptr) :: obj2 type(fckit_shared_ptr) :: obj3 class(*), pointer :: shared_ptr write(0,'(A)') "~~~~~~~~~~~~~~ BEGIN SCOPE ~~~~~~~~~~~~~~" obj1 = create_ObjectFortranSafer(5) FCTEST_CHECK_EQUAL( obj1%owners(), 1 ) obj2 = obj1 FCTEST_CHECK_EQUAL( obj1%owners(), 2 ) shared_ptr => obj2%shared_ptr() select type(shared_ptr) class is(ObjectFortranSafer) obj2_ptr=>shared_ptr end select FCTEST_CHECK( associated(obj2_ptr) ) FCTEST_CHECK_EQUAL( obj2_ptr%id, 5 ) obj3 = obj2 FCTEST_CHECK_EQUAL( obj1%owners(), 3 ) obj1 = obj3 FCTEST_CHECK_EQUAL( obj1%owners(), 3 ) if( .not. final_auto ) then write(0,*) "manual final , owners = ", obj1%owners() call obj1%final() FCTEST_CHECK_EQUAL( obj2%owners(), 2 ) call obj2%final() FCTEST_CHECK_EQUAL( obj3%owners(), 1 ) call obj3%final() endif write(0,'(A)') "~~~~~~~~~~~~~~~ END SCOPE ~~~~~~~~~~~~~~~" call end_scope() end subroutine TEST( test_shared_ptr_safer_manual ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_ptr_safer_manual" call reset_counters() call test_shared_ptr_safer( .false. ) FCTEST_CHECK_EQUAL( final_called , 1 ) FCTEST_CHECK_EQUAL( final_called_after_scope , 0 ) write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST TEST( test_shared_ptr_safer_auto ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_ptr_safer_auto" call reset_counters() call test_shared_ptr_safer( .true. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( final_called, 1 ) FCTEST_CHECK_EQUAL( final_called_after_scope, 1 ) #else FCTEST_CHECK_EQUAL( final_called, 0 ) FCTEST_CHECK_EQUAL( final_called_after_scope, 0 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST ! ----------------------------------------------------------------------------- function create_ObjectFortranUnSafe(id) result(this) type(fckit_shared_ptr) :: this integer :: id class(ObjectFortranUnSafe), pointer :: ptr write(0,'(A,I0)') "Constructing ObjectFortranUnsafe, id = ",id allocate( ObjectFortranUnSafe::ptr ) ptr%id = id call this%share( ptr ) call this%return() end function subroutine test_shared_ptr_unsafe( final_auto ) logical :: final_auto type(fckit_shared_ptr) :: obj1 class(ObjectFortranUnSafe), pointer :: obj2_ptr => null() type(fckit_shared_ptr) :: obj2 class(*), pointer :: shared_ptr write(0,'(A)') "~~~~~~~~~~~~~~ BEGIN SCOPE ~~~~~~~~~~~~~~" obj1 = create_ObjectFortranUnSafe(5) obj2 = obj1 shared_ptr => obj2%shared_ptr() select type(shared_ptr) class is(ObjectFortranUnSafe) obj2_ptr=>shared_ptr end select FCTEST_CHECK( associated(obj2_ptr) ) FCTEST_CHECK_EQUAL( obj2_ptr%id, 5 ) if( .not. final_auto ) then call obj1%final() call obj2%final() endif write(0,'(A)') "~~~~~~~~~~~~~~~ END SCOPE ~~~~~~~~~~~~~~" call end_scope() end subroutine TEST( test_shared_ptr_unsafe_manual ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_ptr_unsafe_manual" call reset_counters() FCTEST_CHECK_EQUAL( final_called, 0 ) call test_shared_ptr_unsafe( .false. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( final_called, 1 ) FCTEST_CHECK_EQUAL( final_called_after_scope, 0 ) #else FCTEST_CHECK_EQUAL( final_called, 0 ) ! --> without finalisation this didnt work as opposed to "safer" FCTEST_CHECK_EQUAL( final_called_after_scope, 0 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST TEST( test_shared_ptr_unsafe_auto ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_ptr_unsafe_auto" call reset_counters() call test_shared_ptr_unsafe( .true. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( final_called, 1 ) FCTEST_CHECK_EQUAL( final_called_after_scope, 1 ) #else FCTEST_CHECK_EQUAL( final_called, 0 ) FCTEST_CHECK_EQUAL( final_called_after_scope, 0 ) write(0,'(A)') "WARNING memory leaked" #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST ! ----------------------------------------------------------------------------- subroutine test_shared_object( final_auto ) logical :: final_auto type(ObjectCXX) :: obj1 type(fckit_shared_ptr) :: obj2 type(ObjectCXX) :: obj3 write(0,'(A)') "~~~~~~~~~~~~~~ BEGIN SCOPE ~~~~~~~~~~~~~~~" obj1 = ObjectCXX(7) FCTEST_CHECK_EQUAL( obj1%id(), 7 ) FCTEST_CHECK_EQUAL( obj1%owners(), 1 ) write(0,*) "obj2 = obj1" obj2 = obj1 FCTEST_CHECK_EQUAL( obj1%owners(), 2 ) write(0,*) "obj3 = obj2" obj3 = obj2 FCTEST_CHECK_EQUAL( obj1%owners(), 3 ) FCTEST_CHECK_EQUAL( obj3%id(), 7 ) write(0,*) "obj1 = obj3" obj1 = obj3 FCTEST_CHECK_EQUAL( obj1%owners(), 3 ) FCTEST_CHECK_EQUAL( obj2%owners(), 3 ) write(0,*) "obj1 = ObjectCXX(4)" obj1 = ObjectCXX(4) FCTEST_CHECK_EQUAL( obj1%owners(), 1 ) FCTEST_CHECK_EQUAL( obj2%owners(), 2 ) if( .not. final_auto ) then call obj1%final() FCTEST_CHECK_EQUAL( obj2%owners(), 2 ) call obj2%final() FCTEST_CHECK_EQUAL( obj3%owners(), 1 ) call obj3%final() endif write(0,'(A)') "~~~~~~~~~~~~~~~ END SCOPE ~~~~~~~~~~~~~~~" call end_scope() end subroutine TEST( test_shared_object_manual ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_manual" call reset_counters() call test_shared_object( final_auto = .false. ) FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST TEST( test_shared_object_auto ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_auto" call reset_counters() call test_shared_object( final_auto = .true. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 0 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST ! ----------------------------------------------------------------------------- subroutine test_shared_object_allocatable( final_auto, deallocate_auto ) logical :: final_auto logical :: deallocate_auto type(ObjectCXX), allocatable :: obj1 write(0,'(A)') "~~~~~~~~~~~~~~ BEGIN SCOPE ~~~~~~~~~~~~~~~" allocate( obj1 ) obj1 = ObjectCXX(7) FCTEST_CHECK_EQUAL( obj1%id(), 7 ) FCTEST_CHECK_EQUAL( obj1%owners(), 1 ) if( .not. final_auto ) then call obj1%final() endif if( .not. deallocate_auto ) then write(0,'(A)') "~~~~~~~~~~~~~~ DEALLOCATE ~~~~~~~~~~~~~~~" deallocate_called = .true. deallocate( obj1 ) endif write(0,'(A)') "~~~~~~~~~~~~~~~ END SCOPE ~~~~~~~~~~~~~~~" call end_scope() end subroutine TEST( test_shared_object_allocatable_auto_auto ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_allocatable_auto_auto" call reset_counters() call test_shared_object_allocatable( final_auto = .true., deallocate_auto = .true. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( cxx_destructor_called(), 1 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 1 ) #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 0 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST TEST( test_shared_object_allocatable_auto_manual ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_allocatable_auto_manual" call reset_counters() call test_shared_object_allocatable( final_auto = .true., deallocate_auto = .false. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( cxx_destructor_called(), 1 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 0 ) #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 0 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST TEST( test_shared_object_allocatable_manual_auto ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_allocatable_manual_auto" call reset_counters() call test_shared_object_allocatable( final_auto = .false., deallocate_auto = .true. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( cxx_destructor_called(), 1 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 0 ) #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 1 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST TEST( test_shared_object_allocatable_manual_manual ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_allocatable_manual_manual" call reset_counters() call test_shared_object_allocatable( final_auto = .false., deallocate_auto = .false. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( cxx_destructor_called(), 1 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 0 ) #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 1 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST ! ----------------------------------------------------------------------------- #if defined(_CRAYFTN) && FCKIT_HAVE_FINAL #define CRAY_WORKAROUND .true. #else #define CRAY_WORKAROUND .false. #endif subroutine test_shared_object_allocatable_list( final_auto, deallocate_auto ) logical :: final_auto logical :: deallocate_auto type(ObjectCXX), allocatable :: list(:) write(0,'(A)') "~~~~~~~~~~~~~~ BEGIN SCOPE ~~~~~~~~~~~~~~~" allocate( list(2) ) list(1) = ObjectCXX(1) list(2) = ObjectCXX(2) write(0,*) "assigned" FCTEST_CHECK_EQUAL( list(1)%id(), 1 ) FCTEST_CHECK_EQUAL( list(1)%owners(), 1 ) FCTEST_CHECK_EQUAL( list(2)%id(), 2 ) FCTEST_CHECK_EQUAL( list(2)%owners(), 1 ) if( .not. final_auto ) then write(0,'(A)') "~~~~~~~~~~~~~~ MANNUALLY DEALLOCATE EACH LIST ELEMENT ~~~~~~~~~~~~~~~" call list(1)%final() call list(2)%final() endif if( .not. deallocate_auto ) then write(0,'(A)') "~~~~~~~~~~~~~~ DEALLOCATE LIST ~~~~~~~~~~~~~~~" deallocate_called = .true. if( CRAY_WORKAROUND ) then write(0,'(A)') "Cray compiler bug (cce/8.5 tested) causes SEGV when the automatic finalization at end of scope kicks in." write(0,'(A)') "Therefore we avoid the deallocate( list ) above, to make test pass." write(0,'(A)') "This means that with FCKIT_HAVE_FINAL turn on, we cannot manually call deallocate(list)" else deallocate( list ) endif endif write(0,'(A)') "~~~~~~~~~~~~~~~ END SCOPE ~~~~~~~~~~~~~~~" call end_scope() end subroutine TEST( test_shared_object_allocatable_list_auto_auto ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_allocatable_list_auto_auto" call reset_counters() call test_shared_object_allocatable_list( final_auto = .true., deallocate_auto = .true. ) #if FCKIT_HAVE_FINAL #if ! FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY && ! FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 2 ) #else write(0,'(A)') "-----------------------------------------" write(0,'(A)') "WARNING: known to fail test" write(0,'(A,I0)') " FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY = ", FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY write(0,'(A,I0)') " FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY = ", FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY #endif #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 0 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST TEST( test_shared_object_allocatable_list_auto_manual ) #if 1 integer :: zero write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_allocatable_list_auto_manual" call reset_counters() call test_shared_object_allocatable_list( final_auto = .true., deallocate_auto = .false. ) write(0,'(A)') '----' zero = 0 if( CRAY_WORKAROUND ) zero = 2 #if FCKIT_HAVE_FINAL #if ! FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY && ! FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), zero ) #endif #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 0 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #else #ifndef __ibmxl__ #warning test_shared_object_allocatable_list_auto_manual disabled #endif #endif END_TEST TEST( test_shared_object_allocatable_list_manual_auto ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_allocatable_list_manual_auto" call reset_counters() call test_shared_object_allocatable_list( final_auto = .false., deallocate_auto = .true. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 0 ) #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #else #ifndef __ibmxl__ #warning test_shared_object_allocatable_list_manual_auto disabled #endif #endif END_TEST TEST( test_shared_object_allocatable_list_manual_manual ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_allocatable_list_manual_manual" call reset_counters() call test_shared_object_allocatable_list( final_auto = .false., deallocate_auto = .false. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 0 ) #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #else #ifndef __ibmxl__ #warning test_shared_object_allocatable_list_manual_manual disabled #endif #endif END_TEST ! ----------------------------------------------------------------------------- subroutine test_shared_object_pointer_list( final_auto, deallocate_auto ) logical :: final_auto logical :: deallocate_auto type(ObjectCXX), pointer :: list(:) write(0,'(A)') "~~~~~~~~~~~~~~ BEGIN SCOPE ~~~~~~~~~~~~~~~" allocate( list(2) ) write(0,*) "allocated" list(1) = ObjectCXX(1) list(2) = ObjectCXX(2) write(0,*) "assigned" FCTEST_CHECK_EQUAL( list(1)%id(), 1 ) FCTEST_CHECK_EQUAL( list(1)%owners(), 1 ) FCTEST_CHECK_EQUAL( list(2)%id(), 2 ) FCTEST_CHECK_EQUAL( list(2)%owners(), 1 ) if( .not. final_auto ) then call list(1)%final() call list(2)%final() endif if( .not. deallocate_auto ) then write(0,'(A)') "~~~~~~~~~~~~~~ DEALLOCATE ~~~~~~~~~~~~~~~" deallocate_called = .true. deallocate( list ) endif write(0,'(A)') "~~~~~~~~~~~~~~~ END SCOPE ~~~~~~~~~~~~~~~" call end_scope() if( associated(list) ) deallocate( list ) end subroutine TEST( test_shared_object_pointer_list_auto_auto ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_pointer_list_auto_auto" call reset_counters() call test_shared_object_pointer_list( final_auto = .true., deallocate_auto = .true. ) #if FCKIT_HAVE_FINAL #if ! FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY && ! FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 2 ) #else write(0,'(A)') "-----------------------------------------" write(0,'(A)') "WARNING: known to fail test" write(0,'(A,I0)') " FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY = ", FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY write(0,'(A,I0)') " FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY = ", FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY #endif #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 0 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST TEST( test_shared_object_pointer_list_auto_manual ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_pointer_list_auto_manual" call reset_counters() call test_shared_object_pointer_list( final_auto = .true., deallocate_auto = .false. ) #if FCKIT_HAVE_FINAL #if ! FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY && ! FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 0 ) #else write(0,'(A)') "-----------------------------------------" write(0,'(A)') "WARNING: known to fail test" write(0,'(A,I0)') " FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY = ", FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY write(0,'(A,I0)') " FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY = ", FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY #endif #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 0 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST TEST( test_shared_object_pointer_list_manual_auto ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_pointer_list_manual_auto" call reset_counters() call test_shared_object_pointer_list( final_auto = .false., deallocate_auto = .true. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 0 ) #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST TEST( test_shared_object_pointer_list_manual_manual ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_pointer_list_manual_manual" call reset_counters() call test_shared_object_pointer_list( final_auto = .false., deallocate_auto = .false. ) #if FCKIT_HAVE_FINAL FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 0 ) #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST ! ----------------------------------------------------------------------------- subroutine test_shared_object_automatic_list( final_auto ) #if 1 logical :: final_auto type(ObjectCXX) :: list(2) write(0,'(A)') "~~~~~~~~~~~~~~ BEGIN SCOPE ~~~~~~~~~~~~~~~" list(1) = ObjectCXX(1) list(2) = ObjectCXX(2) write(0,'(A)') "assigned" FCTEST_CHECK_EQUAL( list(1)%id(), 1 ) FCTEST_CHECK_EQUAL( list(1)%owners(), 1 ) FCTEST_CHECK_EQUAL( list(2)%id(), 2 ) FCTEST_CHECK_EQUAL( list(2)%owners(), 1 ) if( .not. final_auto ) then call list(1)%final() call list(2)%final() endif write(0,'(A)') "~~~~~~~~~~~~~~~ END SCOPE ~~~~~~~~~~~~~~~" call end_scope() #endif end subroutine TEST( test_shared_object_automatic_list_auto ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_automatic_list_auto" call reset_counters() call test_shared_object_automatic_list( final_auto = .true. ) #if FCKIT_HAVE_FINAL #if ! FCKIT_FINAL_BROKEN_FOR_AUTOMATIC_ARRAY && ! FCKIT_FINAL_NOT_INHERITING_FOR_AUTOMATIC_ARRAY FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 2 ) #else write(0,'(A)') "-----------------------------------------" write(0,'(A)') "WARNING: known to fail test" write(0,'(A,I0)') " FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY = ", FCKIT_FINAL_BROKEN_FOR_AUTOMATIC_ARRAY write(0,'(A,I0)') " FCKIT_FINAL_NOT_INHERITING_FOR_AUTOMATIC_ARRAY = ", FCKIT_FINAL_NOT_INHERITING_FOR_AUTOMATIC_ARRAY #endif #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 0 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST TEST( test_shared_object_automatic_list_manual ) #if 1 write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') "TEST test_shared_object_automatic_list_manual" call reset_counters() call test_shared_object_automatic_list( final_auto = .false. ) #if FCKIT_HAVE_FINAL #if ! FCKIT_FINAL_NOT_INHERITING_FOR_AUTOMATIC_ARRAY FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) FCTEST_CHECK_EQUAL( cxx_destructor_called_after_scope(), 0 ) #else write(0,'(A)') "-----------------------------------------" write(0,'(A)') "WARNING: known to fail test" write(0,'(A,I0)') " FCKIT_FINAL_NOT_INHERITING_FOR_AUTOMATIC_ARRAY = ", FCKIT_FINAL_NOT_INHERITING_FOR_AUTOMATIC_ARRAY #endif #else FCTEST_CHECK_EQUAL( cxx_destructor_called(), 2 ) #endif write(0,'(A)') "-------------------------------------------------------------" write(0,'(A)') #endif END_TEST ! ----------------------------------------------------------------------------- END_TESTSUITE fckit-0.14.3/src/tests/test_config.yml0000664000175000017500000000026615202607540020050 0ustar alastairalastair### Test config name: type config types: - typeA: - [memberA, real, 3] - [memberB, real, 3] - typeB: - [memberA, real, 3] - [memberB, int, 2] fckit-0.14.3/src/tests/test_broadcast_file.F900000664000175000017500000000413315202607540021276 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fctest.h" TESTSUITE( test_broadcast_file ) TESTSUITE_INIT use fckit_module call fckit_main%init() call fckit_log%set_fortran_unit(0) ! Write a json file if( fckit_main%taskID() == 0 ) then OPEN (UNIT=199 , FILE="fctest_broadcast.json", STATUS='REPLACE') write(199,'(A)') '{"location":{"city":"Reading","company":"ECMWF","street":"Shinfield Road"},'//& & '"records":[{"age":42,"name":"Anne"},{"age":36,"name":"Bob"}]}' CLOSE(199) endif END_TESTSUITE_INIT TESTSUITE_FINALIZE use fckit_module call fckit_main%final() END_TESTSUITE_FINALIZE TEST( broadcast_file_inline ) #if 1 use fckit_module implicit none type(fckit_mpi_comm) :: comm type(fckit_Configuration) :: config write(0,*) "~~~~~~~~~~~~~~ SCOPE BEGIN ~~~~~~~~~~~~~~~" comm = fckit_mpi_comm() config = fckit_YAMLConfiguration( comm%broadcast_file("fctest_broadcast.json",0) ) FCTEST_CHECK( config%has("location") ) #if ! FCKIT_HAVE_FINAL call config%final() #endif write(0,*) "~~~~~~~~~~~~~~~ SCOPE END ~~~~~~~~~~~~~~~~" #else #warning test broadcast_file_inline disabled #endif END_TEST TEST( broadcast_file_arg ) #if 1 use fckit_module implicit none type(fckit_mpi_comm) :: comm type(fckit_Configuration) :: config type(fckit_buffer) :: buffer write(0,*) "~~~~~~~~~~~~~~ SCOPE BEGIN ~~~~~~~~~~~~~~~" comm = fckit_mpi_comm() buffer = comm%broadcast_file("fctest_broadcast.json",0) config = fckit_YAMLConfiguration( buffer ) FCTEST_CHECK( config%has("location") ) FCTEST_CHECK_EQUAL( buffer%owners(), 1 ) #if ! FCKIT_HAVE_FINAL call buffer%final() #endif write(0,*) "~~~~~~~~~~~~~~~ SCOPE END ~~~~~~~~~~~~~~~~" #else #warning test broadcast_file_arg disabled #endif END_TEST END_TESTSUITE fckit-0.14.3/src/tests/test_downstream_fctest/0000775000175000017500000000000015202607540021607 5ustar alastairalastairfckit-0.14.3/src/tests/test_downstream_fctest/test-downstream.sh.in0000775000175000017500000000156415202607540025721 0ustar alastairalastair#!/usr/bin/env bash # Description: # Build downstream example projects # each individually with make/install # # Usage: # test-individual.sh [CMAKE_ARGUMENTS] SOURCE=@PROJECT_SOURCE_DIR@/doc/fctest_examples BUILD=@CMAKE_CURRENT_BINARY_DIR@/build # Error handling function test_failed { EXIT_CODE=$? { set +ex; } 2>/dev/null if [ $EXIT_CODE -ne 0 ]; then echo "+++++++++++++++++" echo "Test failed" echo "+++++++++++++++++" fi exit $EXIT_CODE } trap test_failed EXIT set -e -o pipefail set -x # Start with clean build rm -rf $BUILD export fckit_DIR=@PROJECT_BINARY_DIR@ export ecbuild_DIR=@ecbuild_DIR@ # Build mkdir -p $BUILD && cd $BUILD cmake $SOURCE \ -DCMAKE_BUILD_TYPE=RelWithDebInfo \ -DECBUILD_2_COMPAT=OFF \ "$@" make VERBOSE=1 ctest -VV { set +ex; } 2>/dev/null echo "+++++++++++++++++" echo "Test passed" echo "+++++++++++++++++" fckit-0.14.3/src/tests/test_downstream_fctest/CMakeLists.txt0000664000175000017500000000210615202607540024346 0ustar alastairalastair # This test builds a package that requires fypp processing # It uses the overriding of compile flags, like IFS is using. # # Test created to avoid regression after fixing issue FCKIT-19, # where compile flags were not propagated to fypp-generated files. if( HAVE_TESTS ) configure_file( test-downstream.sh.in ${CMAKE_CURRENT_BINARY_DIR}/test-downstream.sh @ONLY ) unset( _test_args ) if( CMAKE_TOOLCHAIN_FILE ) if( NOT IS_ABSOLUTE ${CMAKE_TOOLCHAIN_FILE}) set( CMAKE_TOOLCHAIN_FILE "${CMAKE_BINARY_DIR}/${CMAKE_TOOLCHAIN_FILE}" ) endif() list( APPEND _test_args "-DCMAKE_TOOLCHAIN_FILE=${CMAKE_TOOLCHAIN_FILE}" ) endif() foreach( lang C CXX Fortran ) if( CMAKE_${lang}_COMPILER ) list( APPEND _test_args "-DCMAKE_${lang}_COMPILER=${CMAKE_${lang}_COMPILER}" ) endif() if( CMAKE_${lang}_FLAGS ) list( APPEND _test_args "-DCMAKE_${lang}_FLAGS=${CMAKE_${lang}_FLAGS}" ) endif() endforeach() add_test( NAME fckit_test_downstream_fctest COMMAND ${CMAKE_CURRENT_BINARY_DIR}/test-downstream.sh ${_test_args} ) endif() fckit-0.14.3/src/tests/test_log.F900000664000175000017500000000442715202607540017124 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fctest.h" ! ----------------------------------------------------------------------------- TESTSUITE(fckit_test_log) TESTSUITE_INIT use fckit_module implicit none call fckit_main%init() END_TESTSUITE_INIT TESTSUITE_FINALIZE use fckit_module implicit none call fckit_main%final() END_TESTSUITE_FINALIZE ! ----------------------------------------------------------------------------- TEST( test_main ) use fckit_module character(len=:), allocatable :: displayname, name character(len=128) :: logmsg call fckit_main%name(name) call fckit_main%displayname(displayname) write(logmsg,*) "name = "//name//" , displayname = "//displayname call fckit_log%info(logmsg) END_TEST ! ----------------------------------------------------------------------------- TEST( test_log ) use fckit_module, only: log => fckit_log call log%set_stdout() call log%debug("debug") call log%info("info") call log%warning("warning") call log%error("error") call log%error(" ") call log%error("hello again") END_TEST ! ----------------------------------------------------------------------------- TEST( test_file ) use fckit_module, only: log => fckit_log call log%add_file("output_file",style=log%SIMPLE) call log%info("FILE info",newl=.true.,flush=.true.) call log%info("more FILE info",flush=.true.) call log%warning(" more FILE warning",flush=.true.) END_TEST ! ----------------------------------------------------------------------------- TEST( test_fortran_unit ) use fckit_module, only: log => fckit_log call log%set_fortran_unit(unit=6,style=log%TIMESTAMP) call log%info("FORTRAN info",newl=.true.,flush=.true.) call log%warning("FORTRAN warning",newl=.false.) call log%warning(" more FORTRAN warning",flush=.true.) call log%info("more FORTRAN info",flush=.true.) END_TEST ! ----------------------------------------------------------------------------- END_TESTSUITE fckit-0.14.3/src/tests/fckit_run_pytest.sh0000775000175000017500000000076515202607540020760 0ustar alastairalastair#!/usr/bin/env bash # (C) Copyright 2024 ECMWF. # # 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. source $1/fckit_venv/bin/activate pytest $2/test_yaml_reader.py retval=$? deactivate exit $retvalfckit-0.14.3/src/tests/test_configuration.cc0000664000175000017500000000152615202607540021236 0ustar alastairalastair/* * (C) Copyright 2013 ECMWF. * * 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. */ #include #include "eckit/config/LocalConfiguration.h" using namespace eckit; // Fortran binding extern "C" { int c_get_a( const Configuration* ); } int get_a( const Configuration& conf ) { return c_get_a( &conf ); } int main( int argc, char** argv ) { LocalConfiguration conf; conf.set( "a", 10l ); int a = get_a( conf ); if ( a != 10 ) { std::cout << "a != 10" << std::endl; return 1; } return 0; } fckit-0.14.3/src/tests/test_fypp.fypp0000664000175000017500000000277115202607540017741 0ustar alastairalastair#:mute #:set ranks = [1,2,3,4,5] #:set dim = ['',':',':,:',':,:,:',':,:,:,:',':,:,:,:,:'] #:set ftypes = ['integer(c_int)','integer(c_long)','real(c_float)','real(c_double)', 'logical'] #:set dtypes = ['int32', 'int64', 'real32', 'real64', 'logical32'] #:set types = list(zip(dtypes,ftypes)) #:def print_code_location() write(0,*) "This is a very long line in which we will print the code location of this line: ", "${_FILE_}$", ${_LINE_}$ #:enddef #:def ensure(cond, msg=None) if (.not. (${cond}$)) then write(0,*) 'Run-time check failed' write(0,*) 'Condition: ${cond.replace("'", "''")}$' #:if msg is not None write(*,*) 'Message: ', ${msg}$ #:endif write(*,*) 'File: ${_FILE_}$' write(*,*) 'Line: ', ${_LINE_}$ err_code = 1 ! should be throwing error or aborting instead end if #:enddef #:endmute #include "fckit/fctest.h" TESTSUITE( test_fypp ) TEST( allocate_different_types ) use, intrinsic :: iso_c_binding implicit none #:for rank in ranks #:for dtype,ftype in types ${ftype}$, allocatable :: var_${dtype}$_${rank}$(${dim[rank]}$) #:endfor #:endfor #:for rank in ranks #:for dtype,ftype in types if( allocated( var_${dtype}$_${rank}$ ) ) then write(0,*) "suppress warning" endif #:endfor #:endfor END_TEST TEST( test_macros ) integer :: a integer :: err_code a = 1 err_code = 0 @:print_code_location() @:ensure( a == 2, "a must be 2" ) FCTEST_CHECK_EQUAL(err_code, 1) END_TEST END_TESTSUITE fckit-0.14.3/src/tests/test_owned_object.cc0000664000175000017500000000276115202607540021033 0ustar alastairalastair#include #include #include #include #include "eckit/memory/Owned.h" static int destructor_called = 0; static int destructor_called_after_scope = 0; static int scope_ended = 0; extern "C" { void fckit_write_to_fortran_unit( int unit, const char* msg ); int fckit_fortranunit_stdout(); int fckit_fortranunit_stderr(); } class Object : eckit::Owned { public: Object( int i ) : eckit::Owned(), i_( i ) { std::stringstream out; out << "constructing Object " << i_; fckit_write_to_fortran_unit( fckit_fortranunit_stderr(), out.str().c_str() ); } ~Object() { std::stringstream out; out << "destructing Object " << i_; fckit_write_to_fortran_unit( fckit_fortranunit_stderr(), out.str().c_str() ); destructor_called += 1; if ( scope_ended ) destructor_called_after_scope += 1; } int id() const { return i_; } private: int i_; }; extern "C" { Object* new_Object( int i ) { return new Object( i ); } void delete_Object( Object* p ) { delete p; } int Object__id( const Object* p ) { return p->id(); } int cxx_destructor_called() { return destructor_called; } int cxx_destructor_called_after_scope() { return destructor_called_after_scope; } void cxx_reset_counters() { destructor_called = 0; destructor_called_after_scope = 0; scope_ended = 0; } void cxx_end_scope() { scope_ended = 1; } } fckit-0.14.3/src/tests/test_configuration_fails.F900000664000175000017500000000330215202607540022357 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fctest.h" ! ----------------------------------------------------------------------------- TESTSUITE(fctest_fckit_configuration_fails) ! ----------------------------------------------------------------------------- TESTSUITE_INIT use fckit_module call fckit_main%init() ! With Apple Silicon (M1), using Apple clang 12.0.0 for C++ and Homebrew GCC 10.2.0_4 for Fortran ! it appears that the Fortran needs to trap the C++ exceptions via SIGTRAP call fckit_signal%set_handler( fckit_signal%SIGTRAP() ) call fckit_signal%set_handler( fckit_signal%SIGBUS() ) END_TESTSUITE_INIT ! ----------------------------------------------------------------------------- TESTSUITE_FINALIZE use fckit_module call fckit_main%final() END_TESTSUITE_FINALIZE ! ----------------------------------------------------------------------------- TEST(test_throw) !! ENABLE TO TEST IF THROW WILL WORK #if 1 use fckit_configuration_module type(fckit_Configuration) :: config integer :: missing_value write(0,*) "~~~~~~~~~~~~~~ SCOPE BEGIN ~~~~~~~~~~~~~~~" config = fckit_Configuration() call config%get_or_die("missing",missing_value) call config%final() write(0,*) "~~~~~~~~~~~~~~~ SCOPE END ~~~~~~~~~~~~~~~~" #endif END_TEST ! ----------------------------------------------------------------------------- END_TESTSUITE fckit-0.14.3/src/tests/CMakeLists.txt0000664000175000017500000001261315202607540017560 0ustar alastairalastair# (C) Copyright 2013 ECMWF. # # 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. cmake_policy( SET CMP0064 NEW ) # Recognize ``TEST`` as operator for the ``if()`` command. (introduced in CMake version 3.4) add_fctest( TARGET fckit_test_array LINKER_LANGUAGE Fortran SOURCES test_array.F90 LIBS fckit) add_fctest( TARGET fckit_test_resource LINKER_LANGUAGE Fortran SOURCES test_resource.F90 ARGS -integer 10 -long 5000000000 -float 0.123456 -double 0.1234567890123456789 -string "hello world" CONDITION HAVE_ECKIT LIBS fckit) add_fctest( TARGET fckit_test_log LINKER_LANGUAGE Fortran SOURCES test_log.F90 CONDITION HAVE_ECKIT LIBS fckit) add_fctest( TARGET fckit_test_shared_ptr LINKER_LANGUAGE Fortran SOURCES test_shared_ptr.F90 test_shared_ptr.cc LIBS fckit) add_fctest( TARGET fckit_test_owned_object LINKER_LANGUAGE Fortran SOURCES test_owned_object.F90 test_owned_object.cc LIBS fckit eckit CONDITION HAVE_ECKIT ) add_fctest( TARGET fckit_test_mpi LINKER_LANGUAGE Fortran SOURCES test_mpi.F90 MPI 4 CONDITION HAVE_MPI LIBS fckit) add_fctest( TARGET fckit_test_abort LINKER_LANGUAGE Fortran SOURCES test_abort.F90 CONDITION HAVE_ECKIT LIBS fckit) add_fctest( TARGET fckit_test_map LINKER_LANGUAGE Fortran SOURCES test_map.F90 CONDITION FCKIT_HAVE_ECKIT_TENSOR LIBS fckit) add_fctest( TARGET fckit_test_tensor LINKER_LANGUAGE Fortran SOURCES test_tensor.F90 test_tensor.cc INCLUDES ${ECKIT_INCLUDE_DIRS} CONDITION FCKIT_HAVE_ECKIT_TENSOR LIBS eckit fckit) add_fctest( TARGET fckit_test_configuration LINKER_LANGUAGE Fortran SOURCES test_configuration.F90 CONDITION HAVE_ECKIT LIBS fckit) if( TEST fckit_test_configuration ) if( NOT CMAKE_VERSION VERSION_LESS 3.15 ) # support for COMPILE_LANG_AND_ID generator expression target_compile_options( fckit_test_configuration PRIVATE $<$:-Wno-uninitialized> ) endif() endif() add_fctest( TARGET fckit_test_configuration_fails LINKER_LANGUAGE Fortran SOURCES test_configuration_fails.F90 CONDITION HAVE_ECKIT LIBS fckit) if( TEST fckit_test_configuration_fails ) set_tests_properties( fckit_test_configuration_fails PROPERTIES PASS_REGULAR_EXPRESSION "Could not find \"missing\" in Configuration" TIMEOUT 20 ) endif() add_fctest( TARGET fckit_test_broadcast_file LINKER_LANGUAGE Fortran SOURCES test_broadcast_file.F90 MPI 4 CONDITION HAVE_MPI LIBS fckit) add_fctest( TARGET fckit_test_fypp LINKER_LANGUAGE Fortran SOURCES test_fypp.fypp LIBS fckit ) ecbuild_add_test( TARGET fckit_test_configuration_cpp LINKER_LANGUAGE Fortran SOURCES test_configuration.cc test_configuration_fortcode.F90 INCLUDES ${ECKIT_INCLUDE_DIRS} CONDITION HAVE_ECKIT LIBS fckit eckit eckit_mpi ) if( TEST fckit_test_configuration_cpp ) set_property( TEST fckit_test_configuration_cpp APPEND PROPERTY LABELS "fortran" ) endif() ecbuild_add_test( TARGET fckit_test_cpp LINKER_LANGUAGE Fortran SOURCES test_cpp.cc test_cpp_fortcode.F90 INCLUDES ${ECKIT_INCLUDE_DIRS} ENVIRONMENT "DEBUG=1" CONDITION HAVE_ECKIT LIBS fckit eckit eckit_mpi ) ### Fix linking for C++ test executables linked with Fortran linker if( CMAKE_Fortran_COMPILER_ID MATCHES "PGI|NVHPC" ) set( NO_MAIN "-Mnomain" ) elseif( CMAKE_Fortran_COMPILER_ID MATCHES "Intel" ) set( NO_MAIN "-nofor-main" ) elseif( CMAKE_Fortran_COMPILER_ID MATCHES "Fujitsu" ) set( NO_MAIN "-mlcmain=main" ) elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "Flang" ) # we use STREUQAL to avoid a false match with LLVMFlang set( NO_MAIN "-fno-fortran-main" ) endif() if( NO_MAIN ) foreach( _test fckit_test_configuration_cpp fckit_test_cpp ) if( TEST ${_test} ) set_target_properties(${_test} PROPERTIES LINK_FLAGS ${NO_MAIN} ) endif() endforeach() endif() ### Quarantaine tests if requested foreach( _test ${FCKIT_QUARANTAINED_TESTS} ) if( TEST ${_test} ) set_tests_properties( ${_test} PROPERTIES DISABLED 1 ) ecbuild_warn("Test ${_test} is quarantined (shows as not run)") endif() endforeach() ### Test downstream find_package(fckit) projects add_subdirectory( test_downstream_fypp ) add_subdirectory( test_downstream_fctest ) ### Test fckit_yaml_reader if( HAVE_FCKIT_VENV ) ecbuild_add_test( COMMAND ${CMAKE_CURRENT_SOURCE_DIR}/fckit_run_pytest.sh ARGS ${CMAKE_CURRENT_BINARY_DIR}/../.. ${CMAKE_CURRENT_SOURCE_DIR} ) endif() fckit-0.14.3/src/tests/test_resource.F900000664000175000017500000000326615202607540020172 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fctest.h" ! ----------------------------------------------------------------------------- TESTSUITE(fckit_test_resource) TESTSUITE_INIT use fckit_module call fckit_main%init() END_TESTSUITE_INIT ! ----------------------------------------------------------------------------- TEST( test_resource ) use, intrinsic :: iso_c_binding use fckit_module integer(c_int32_t) :: intval integer(c_int64_t) :: longval real(c_float) :: floatval real(c_double) :: doubleval character(len=:), allocatable :: stringval call fckit_resource("-integer",0_c_int32_t,intval) FCTEST_CHECK_EQUAL(intval, 10_c_int32_t) write(0,*) "integer = ",intval call fckit_resource("-long",0_c_int64_t,longval) write(0,*) "long = ",longval FCTEST_CHECK_EQUAL(longval, 5000000000_c_int64_t) call fckit_resource("-float",0._c_float,floatval) FCTEST_CHECK_EQUAL(floatval, 0.123456_c_float ) write(0,*) "float = ",floatval call fckit_resource("-double",0._c_double,doubleval) FCTEST_CHECK_EQUAL(doubleval, 0.1234567890123456789_c_double ) write(0,*) "double = ",doubleval call fckit_resource("-string","default",stringval) FCTEST_CHECK_EQUAL(stringval, "hello world") write(0,*) "string = ",stringval END_TEST ! ----------------------------------------------------------------------------- END_TESTSUITE fckit-0.14.3/src/fckit/0000775000175000017500000000000015202607540014753 5ustar alastairalastairfckit-0.14.3/src/fckit/Libfckit.h0000664000175000017500000000201215202607540016646 0ustar alastairalastair/* * (C) Copyright 2013 ECMWF. * * 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. */ #ifndef fckit_Libfckit_h #define fckit_Libfckit_h #include "eckit/system/Library.h" namespace fckit { //---------------------------------------------------------------------------------------------------------------------- class Libfckit : public eckit::system::Library { public: Libfckit(); static const Libfckit& instance(); protected: const void* addr() const; virtual std::string version() const; virtual std::string gitsha1( unsigned int count ) const; }; //---------------------------------------------------------------------------------------------------------------------- } // namespace fckit #endif fckit-0.14.3/src/fckit/fckit_yaml_reader/0000775000175000017500000000000015202607540020417 5ustar alastairalastairfckit-0.14.3/src/fckit/fckit_yaml_reader/fckit_yaml_reader/0000775000175000017500000000000015202607540024063 5ustar alastairalastairfckit-0.14.3/src/fckit/fckit_yaml_reader/fckit_yaml_reader/ruamel_reader.py0000664000175000017500000000125315202607540027245 0ustar alastairalastair#!/usr/bin/env python3 # (C) Copyright 2013 ECMWF. # # 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. from ruamel.yaml import YAML class ruamel_reader(YAML): """ A minimal wrapper for ruamel.yaml to create an API consistent with pyyaml. """ def __init__(self): super().__init__(typ='safe') def safe_load(self, stream): return self.load(stream) fckit-0.14.3/src/fckit/fckit_yaml_reader/fckit_yaml_reader/__init__.py0000664000175000017500000000064515202607540026201 0ustar alastairalastair# (C) Copyright 2013 ECMWF. # # 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. from fckit_yaml_reader.yaml_reader import *fckit-0.14.3/src/fckit/fckit_yaml_reader/fckit_yaml_reader/yaml_reader.py0000664000175000017500000000074715202607540026731 0ustar alastairalastair#!/usr/bin/env python3 # (C) Copyright 2013 ECMWF. # # 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. from fckit_yaml_reader.ruamel_reader import ruamel_reader as YAML __all__ = ["YAML"]fckit-0.14.3/src/fckit/fckit_yaml_reader/pyproject.toml0000664000175000017500000000061415202607540023334 0ustar alastairalastair[build-system] requires = [ "setuptools>=75.0.0", "wheel" ] build-backend = "setuptools.build_meta" [project] name = "fckit_yaml_reader" version = "0.0.1" requires-python = ">=3.8" dependencies = [ "ruamel.yaml>=0.18.6", "ruamel.yaml.clib>=0.2.8", "fypp>=3.2" ] license = {text = "Apache-2.0"} description = "A minimal wrapper for ruamel.yaml to create an API consistent with pyyaml." fckit-0.14.3/src/fckit/fctest.F900000664000175000017500000002456215202607540016534 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. module fctest use, intrinsic :: iso_c_binding, only: c_float, c_double, c_int32_t, c_int64_t, c_char, c_int implicit none integer(c_int32_t), parameter :: sp=c_float integer(c_int32_t), parameter :: dp=c_double public character(len=1024) :: source_file integer(c_int32_t) :: exit_status interface FCE module procedure fctest_check_equal_int32 module procedure fctest_check_equal_int64_int32 module procedure fctest_check_equal_int32_int64 module procedure fctest_check_equal_int64 module procedure fctest_check_equal_real32 module procedure fctest_check_equal_real64 module procedure fctest_check_equal_string module procedure fctest_check_equal_int32_r1 module procedure fctest_check_equal_int64_r1 module procedure fctest_check_equal_real32_r1 module procedure fctest_check_equal_real64_r1 module procedure fctest_check_equal_logical end interface FCE interface FCC module procedure fctest_check_close_real32 module procedure fctest_check_close_real64 module procedure fctest_check_close_real32_r1 module procedure fctest_check_close_real64_r1 end interface FCC interface ERR module procedure fctest_error end interface ERR ! TODO: These should be private ! private :: c_float, c_double, c_int32_t, c_int64_t, c_char contains function sweep_leading_blanks(in_str) character(kind=c_char,len=*), intent(in) :: in_str character(kind=c_char,len=512) :: sweep_leading_blanks character(kind=c_char) :: ch integer(c_int32_t) :: j do j=1, len_trim(in_str) ! get j-th char ch = in_str(j:j) if (ch .ne. " ") then sweep_leading_blanks = trim(in_str(j:len_trim(in_str))) return endif end do end function sweep_leading_blanks subroutine fctest_error(line) integer(c_int32_t), intent(in) :: line write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) exit_status=1 end subroutine subroutine fctest_check_equal_int32(V1,V2,line) integer(c_int32_t), intent(in) :: V1, V2 integer(c_int32_t), intent(in) :: line if(V1/=V2) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) write(0,*) "--> [",V1,"!=",V2,"]" exit_status=1 endif end subroutine subroutine fctest_check_equal_int64(V1,V2,line) integer(c_int64_t), intent(in) :: V1, V2 integer(c_int32_t), intent(in) :: line if(V1/=V2) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) write(0,*) "--> [",V1,"!=",V2,"]" exit_status=1 endif end subroutine subroutine fctest_check_equal_int64_int32(V1,V2,line) integer(c_int64_t), intent(in) :: V1 integer(c_int32_t), intent(in) :: V2 integer(c_int32_t), intent(in) :: line if(V1/=V2) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) write(0,*) "--> [",V1,"!=",V2,"]" exit_status=1 endif end subroutine subroutine fctest_check_equal_int32_int64(V1,V2,line) integer(c_int32_t), intent(in) :: V1 integer(c_int64_t), intent(in) :: V2 integer(c_int32_t), intent(in) :: line if(V1/=V2) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) write(0,*) "--> [",V1,"!=",V2,"]" exit_status=1 endif end subroutine subroutine fctest_check_equal_real32(V1,V2,line) real(kind=c_float), intent(in) :: V1, V2 integer(c_int32_t), intent(in) :: line if(V1/=V2) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) write(0,*) "--> [",V1,"!=",V2,"]" exit_status=1 endif end subroutine subroutine fctest_check_equal_real64(V1,V2,line) real(kind=c_double), intent(in) :: V1, V2 integer(c_int32_t), intent(in) :: line if(V1/=V2) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) write(0,*) "--> [",V1,"!=",V2,"]" exit_status=1 endif end subroutine subroutine fctest_check_equal_logical(V1,V2,line) logical, intent(in) :: V1, V2 integer(c_int32_t), intent(in) :: line if(V1.neqv.V2) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) write(0,*) "--> [",V1,"!=",V2,"]" exit_status=1 endif end subroutine subroutine fctest_check_equal_string(V1,V2,line) character(kind=c_char,len=*), intent(in) :: V1, V2 integer(c_int32_t), intent(in) :: line if(V1/=V2) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) write(0,*) "--> [",V1,"!=",V2,"]" exit_status=1 endif end subroutine subroutine fctest_check_equal_int32_r1(V1,V2,line) integer(c_int32_t), intent(in) :: V1(:), V2(:) integer(c_int32_t), intent(in) :: line logical :: compare = .True. integer(c_int32_t) :: j if( size(V1) /= size(V2) ) compare = .False. if( compare .eqv. .True. ) then do j=1,size(V1) if( V1(j)/=V2(j) ) compare = .False. enddo endif if( compare .eqv. .False. ) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) if( size(V1) <= 30 ) then write(0,*) "--> [ ",V1," ] != [ ",V2," ] " endif exit_status=1 endif end subroutine subroutine fctest_check_equal_int64_r1(V1,V2,line) integer(c_int64_t), intent(in) :: V1(:), V2(:) integer(c_int32_t), intent(in) :: line logical :: compare = .True. integer(c_int32_t) :: j if( size(V1) /= size(V2) ) compare = .False. if( compare .eqv. .True. ) then do j=1,size(V1) if( V1(j)/=V2(j) ) compare = .False. enddo endif if( compare .eqv. .False. ) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) if( size(V1) <= 30 ) then write(0,*) "--> [ ",V1," ] != [ ",V2," ]" endif exit_status=1 endif end subroutine subroutine fctest_check_equal_real32_r1(V1,V2,line) real(kind=c_float), intent(in) :: V1(:), V2(:) integer(c_int32_t), intent(in) :: line logical :: compare integer(c_int32_t) :: j compare = .True. if( size(V1) /= size(V2) ) compare = .False. if( compare .eqv. .True. ) then do j=1,size(V1) if( V1(j)/=V2(j) ) compare = .False. enddo endif if( compare .eqv. .False. ) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) if( size(V1) <= 30 ) then write(0,*) "--> [ ",V1," ] != [ ",V2," ]" endif exit_status=1 endif end subroutine subroutine fctest_check_equal_real64_r1(V1,V2,line) real(kind=c_double), intent(in) :: V1(:), V2(:) integer(c_int32_t), intent(in) :: line logical :: compare integer(c_int32_t) :: j compare = .True. if( size(V1) /= size(V2) ) compare = .False. if( compare .eqv. .True. ) then do j=1,size(V1) if( V1(j)/=V2(j) ) compare = .False. enddo endif if( compare .eqv. .False. ) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) if( size(V1) <= 30 ) then write(0,*) "--> [ ",V1," ] != [ ",V2," ]" endif exit_status=1 endif end subroutine subroutine fctest_check_close_real32(V1,V2,TOL,line) real(kind=c_float), intent(in) :: V1, V2, TOL integer(c_int32_t), intent(in) :: line if(.not.(abs(V1-V2)<=TOL)) then; write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) write(0,*) "--> [",V1,"!=",V2,"]" exit_status=1 endif end subroutine subroutine fctest_check_close_real64(V1,V2,TOL,line) real(kind=c_double), intent(in) :: V1, V2, TOL integer(c_int32_t), intent(in) :: line if(.not.(abs(V1-V2)<=TOL)) then; write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) write(0,*) "--> [",V1,"!=",V2,"]" exit_status=1 endif end subroutine subroutine fctest_check_close_real32_r1(V1,V2,TOL,line) real(kind=c_float), intent(in) :: V1(:), V2(:) real(kind=c_float), intent(in) :: TOL integer(c_int32_t), intent(in) :: line logical :: compare integer(c_int32_t) :: j compare = .True. if( size(V1) /= size(V2) ) compare = .False. if( compare .eqv. .True. ) then do j=1,size(V1) if(.not.(abs(V1(j)-V2(j))<=TOL)) compare = .False. enddo endif if( compare .eqv. .False. ) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) if( size(V1) <= 30 ) then write(0,*) "--> [ ",V1," ] != [ ",V2," ]" endif exit_status=1 endif end subroutine subroutine fctest_check_close_real64_r1(V1,V2,TOL,line) real(kind=c_double), intent(in) :: V1(:), V2(:) real(kind=c_double), intent(in) :: TOL integer(c_int32_t), intent(in) :: line logical :: compare integer(c_int32_t) :: j compare = .True. if( size(V1) /= size(V2) ) compare = .False. if( compare .eqv. .True. ) then do j=1,size(V1) if(.not.(abs(V1(j)-V2(j))<=TOL)) compare = .False. enddo endif if( compare .eqv. .False. ) then write(0,'(2A,I0,2A)') trim(source_file),":",line,": warning: ",trim(sweep_leading_blanks(get_source_line(line))) if( size(V1) <= 30 ) then write(0,*) "--> [ ",V1," ] != [ ",V2," ]" endif exit_status=1 endif end subroutine function get_source_line(line_number) result(source_line) integer(c_int32_t), intent(in) :: line_number ! Variables integer(c_int32_t) stat, jline character(kind=c_char,len=512) :: source_line ! open input file open (10, file=source_file, status='old', iostat=stat) if (stat .ne. 0)then source_line = 'source_file '//trim(source_file)//' can not be opened' close(10) return end if ! process file do jline=1,line_number read (10, '(A)', end=99) source_line ! read line from input file enddo close(10) ! close files 99 continue close (10) end function get_source_line end module fctest fckit-0.14.3/src/fckit/Log.cc0000664000175000017500000001445515202607540016014 0ustar alastairalastair/* * (C) Copyright 2013 ECMWF. * * 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. */ #include "fckit/Log.h" #include #include "eckit/exception/Exceptions.h" #include "eckit/log/CallbackTarget.h" #include "eckit/log/FileTarget.h" #include "eckit/log/OStreamTarget.h" #include "eckit/log/PrefixTarget.h" #include "eckit/log/TimeStampTarget.h" #include "eckit/runtime/Main.h" #include "eckit/system/Library.h" #include "eckit/system/LibraryManager.h" #include "fckit/Libfckit.h" using eckit::Channel; using eckit::LogTarget; using eckit::Main; using eckit::PrefixTarget; using eckit::system::Library; using eckit::system::LibraryManager; using fckit::Log; extern "C" { void fckit_write_to_fortran_unit( int unit, const char* msg ); int fckit_fortranunit_stdout(); int fckit_fortranunit_stderr(); } namespace { static void write_to_fortran_unit( void* ctxt, const char* msg ) { fckit_write_to_fortran_unit( *static_cast( ctxt ), msg ); } static std::string debug_prefix( const std::string& libname ) { std::string s = libname; std::transform( s.begin(), s.end(), s.begin(), ::toupper ); s += "_DEBUG"; return s; } void libs_debug_addTarget( LogTarget* target ) { for ( std::string libname : LibraryManager::list() ) { const Library& lib = LibraryManager::lookup( libname ); if ( lib.debug() ) { lib.debugChannel().addTarget( new PrefixTarget( debug_prefix( libname ), target ) ); } } } void libs_debug_setTarget( LogTarget* target ) { for ( std::string libname : LibraryManager::list() ) { const Library& lib = LibraryManager::lookup( libname ); if ( lib.debug() ) { lib.debugChannel().setTarget( new PrefixTarget( debug_prefix( libname ), target ) ); } } } } // namespace namespace fckit { class FortranUnitTarget : public eckit::CallbackTarget { public: FortranUnitTarget( int unit ); private: int unit_; }; FortranUnitTarget::FortranUnitTarget( int unit ) : eckit::CallbackTarget( &write_to_fortran_unit, &unit_ ), unit_( unit ) {} LogTarget* createStyleTarget( LogTarget* target, Log::Style style, const char* prefix ) { if ( style == Log::SIMPLE ) return target; if ( style == Log::PREFIX ) return new eckit::PrefixTarget( prefix, target ); if ( style == Log::TIMESTAMP ) return new eckit::TimeStampTarget( prefix, target ); NOTIMP; } void Log::addFortranUnit( int unit, Style style, const char* ) { LogTarget* funit = new FortranUnitTarget( unit ); info().addTarget( createStyleTarget( funit, style, "(I)" ) ); warning().addTarget( createStyleTarget( funit, style, "(W)" ) ); error().addTarget( createStyleTarget( funit, style, "(E)" ) ); if ( Main::instance().debug() ) debug().addTarget( createStyleTarget( funit, style, "(D)" ) ); libs_debug_addTarget( funit ); } void Log::setFortranUnit( int unit, Style style, const char* ) { LogTarget* funit = new FortranUnitTarget( unit ); info().setTarget( createStyleTarget( funit, style, "(I)" ) ); warning().setTarget( createStyleTarget( funit, style, "(W)" ) ); error().setTarget( createStyleTarget( funit, style, "(E)" ) ); if ( Main::instance().debug() ) debug().setTarget( createStyleTarget( funit, style, "(D)" ) ); libs_debug_setTarget( funit ); } void Log::addFile( const char* path, Style style, const char* ) { LogTarget* file = new eckit::FileTarget( path ); info().addTarget( createStyleTarget( file, style, "(I)" ) ); warning().addTarget( createStyleTarget( file, style, "(W)" ) ); error().addTarget( createStyleTarget( file, style, "(E)" ) ); if ( Main::instance().debug() ) debug().addTarget( createStyleTarget( file, style, "(D)" ) ); libs_debug_addTarget( file ); } void Log::setFile( const char* path, Style style, const char* ) { LogTarget* file = new eckit::FileTarget( path ); info().setTarget( createStyleTarget( file, style, "(I)" ) ); warning().setTarget( createStyleTarget( file, style, "(W)" ) ); error().setTarget( createStyleTarget( file, style, "(E)" ) ); if ( Main::instance().debug() ) debug().setTarget( createStyleTarget( file, style, "(D)" ) ); libs_debug_setTarget( file ); } void Log::addFile( const std::string& path, Style style, const std::string& prefix ) { return addFile( path.c_str(), style, prefix.c_str() ); } void Log::setFile( const std::string& path, Style style, const std::string& prefix ) { return setFile( path.c_str(), style, prefix.c_str() ); } void Log::addStdOut( Style style, const char* ) { LogTarget* stdout = new eckit::OStreamTarget( std::cout ); info().addTarget( createStyleTarget( stdout, style, "(I)" ) ); warning().addTarget( createStyleTarget( stdout, style, "(W)" ) ); error().addTarget( createStyleTarget( stdout, style, "(E)" ) ); if ( Main::instance().debug() ) debug().addTarget( createStyleTarget( stdout, style, "(D)" ) ); libs_debug_addTarget( stdout ); } void Log::setStdOut( Style style, const char* ) { LogTarget* stdout = new eckit::OStreamTarget( std::cout ); info().setTarget( createStyleTarget( stdout, style, "(I)" ) ); warning().setTarget( createStyleTarget( stdout, style, "(W)" ) ); error().setTarget( createStyleTarget( stdout, style, "(E)" ) ); if ( Main::instance().debug() ) debug().setTarget( createStyleTarget( stdout, style, "(D)" ) ); libs_debug_setTarget( stdout ); } int Log::output_unit() { return fckit_fortranunit_stdout(); } int Log::error_unit() { return fckit_fortranunit_stderr(); } void Log::reset() { eckit::Log::reset(); for ( std::string libname : LibraryManager::list() ) { if ( Channel& debug = LibraryManager::lookup( libname ).debugChannel() ) { debug.reset(); } } } void Log::flush() { eckit::Log::flush(); for ( std::string libname : LibraryManager::list() ) { if ( Channel& debug = LibraryManager::lookup( libname ).debugChannel() ) { debug.flush(); } } } } // namespace fckit fckit-0.14.3/src/fckit/Libfckit.cc0000664000175000017500000000257715202607540017024 0ustar alastairalastair/* * (C) Copyright 2013 ECMWF. * * 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. */ #include #include #include "fckit/Libfckit.h" #include "fckit/fckit.h" namespace fckit { //---------------------------------------------------------------------------------------------------------------------- // eckit 0.16.5 improved library registration using REGISTER_LIBRARY macro REGISTER_LIBRARY( Libfckit ); Libfckit::Libfckit() : eckit::system::Library( "fckit" ) {} const Libfckit& Libfckit::instance() { static Libfckit library; return library; } const void* Libfckit::addr() const { return this; } std::string Libfckit::version() const { return FCKIT_VERSION; } std::string Libfckit::gitsha1( unsigned int count ) const { static std::string sha1( FCKIT_GIT_SHA1 ); if ( sha1.empty() ) { return "not available"; } sha1 = sha1.substr( 0, std::min( count, 40u ) ); return sha1.c_str(); } //---------------------------------------------------------------------------------------------------------------------- } // namespace fckit fckit-0.14.3/src/fckit/Main.cc0000664000175000017500000002471115202607540016153 0ustar alastairalastair/* * (C) Copyright 2013 ECMWF. * * 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. */ #include "fckit/Main.h" #include #include #include #include #include #include "eckit/config/LibEcKit.h" #include "eckit/exception/Exceptions.h" #include "eckit/mpi/Comm.h" #include "eckit/os/BackTrace.h" #include "eckit/thread/AutoLock.h" #include "eckit/thread/Mutex.h" #include "eckit/thread/Once.h" #include "fckit/Log.h" static eckit::Once local_mutex; using int32 = std::int32_t; namespace fckit { static std::string exception_what; static eckit::CodeLocation exception_location; static std::string exception_callstack; //------------------------------------------------------------------------------------------------------------------ void fckit_terminate() { // This routine is called for uncaught exceptions. // It can be set with std::set_terminate( &fckit_terminate ) Log::flush(); if ( std::exception_ptr eptr = std::current_exception() ) { std::ostream& out = Log::error(); try { std::rethrow_exception( eptr ); // throw to recognise the type } catch ( const eckit::Abort& exception ) { out << "\n" << "=========================================\n" << "Aborting " << Main::instance().displayName() << "\n" << "-----------------------------------------\n" << exception.what() << "\n"; if ( exception.location() ) out << "-----------------------------------------\n" << "LOCATION: " << exception.location() << "\n"; out << "-----------------------------------------\n" << "BACKTRACE\n" << "-----------------------------------------\n" << eckit::BackTrace::dump() << "\n" << "=========================================\n" << std::endl; exception_what = exception.what(); exception_location = exception.location(); exception_callstack = exception.callStack(); } catch ( const eckit::Exception& exception ) { out << "\n" << "=========================================\n" << "TERMINATING " << Main::instance().displayName() << "\n" << "-----------------------------------------\n" << exception.what() << "\n" << "-----------------------------------------\n"; if ( exception.location() ) out << "LOCATION: " << exception.location() << "\n" << "-----------------------------------------\n"; out << "BACKTRACE\n" << "-----------------------------------------\n" << eckit::BackTrace::dump() << "\n" << "=========================================\n" << std::endl; exception_what = exception.what(); exception_location = exception.location(); exception_callstack = eckit::BackTrace::dump(); } catch ( const std::exception& exception ) { out << "\n" << "=========================================\n" << "TERMINATING " << Main::instance().displayName() << "\n" << "-----------------------------------------\n" << exception.what() << "\n" << "-----------------------------------------\n" << "BACKTRACE\n" << "-----------------------------------------\n" << eckit::BackTrace::dump() << "\n" << "=========================================\n" << std::endl; exception_what = exception.what(); exception_location = eckit::CodeLocation(); exception_callstack = eckit::BackTrace::dump(); } catch ( ... ) { out << "\n" << "=========================================\n" << "TERMINATING " << Main::instance().displayName() << "\n" << "-----------------------------------------\n" << "BACKTRACE\n" << "-----------------------------------------\n" << eckit::BackTrace::dump() << "\n" << "=========================================" << std::endl; exception_what = "Uncaught exception"; exception_location = eckit::CodeLocation(); exception_callstack = eckit::BackTrace::dump(); } } eckit::LibEcKit::instance().abort(); // Just in case we end up here, as last resort, exit immediately without // cleanup. std::_Exit( EXIT_FAILURE ); } //------------------------------------------------------------------------------------------------------------------ void fckit_signal_handler( int32 signum ) { Signal signal = Signals::instance().signal( signum ); // Restore default signal handlers in case another signal is raised by // accident fckit::Signals::instance().restoreAllSignalHandlers(); std::ostream& out = fckit::Log::error(); out << "\n" << "=========================================\n" << signal << " (signal intercepted by fckit)\n"; out << "-----------------------------------------\n" << "BACKTRACE\n" << "-----------------------------------------\n" << eckit::BackTrace::dump() << "\n" << "=========================================\n" << std::endl; exception_what = "Signal " + signal.str(); exception_location = eckit::CodeLocation(); exception_callstack = eckit::BackTrace::dump(); eckit::LibEcKit::instance().abort(); // Just in case we end up here, which normally we shouldn't. std::_Exit( EXIT_FAILURE ); } Signals& Signals::instance() { static Signals signals; return signals; } void Signals::restoreSignalHandler( int signum ) { if ( registered_signals_.find( signum ) != registered_signals_.end() ) { eckit::Log::debug() << "\n"; eckit::Log::debug() << "Restoring default signal handler for signal " << registered_signals_[signum] << "\n"; std::signal( signum, SIG_DFL ); eckit::Log::debug() << std::endl; registered_signals_.erase( signum ); } } void Signals::restoreAllSignalHandlers() { eckit::Log::debug() << "\n"; for ( registered_signals_t::const_iterator it = registered_signals_.begin(); it != registered_signals_.end(); ++it ) { eckit::Log::debug() << "Restoring default signal handler for signal " << it->second.str() << "\n"; std::signal( it->first, SIG_DFL ); } eckit::Log::debug() << std::endl; registered_signals_.clear(); } const Signal& Signals::signal( int signum ) const { return registered_signals_.at( signum ); } std::ostream& operator<<( std::ostream& out, const Signal& signal ) { out << signal.str(); return out; } void Signals::setSignalHandlers() { setSignalHandler( SIGABRT ); setSignalHandler( SIGFPE ); setSignalHandler( SIGILL ); setSignalHandler( SIGINT ); setSignalHandler( SIGSEGV ); setSignalHandler( SIGTERM ); setSignalHandler( SIGKILL ); } void Signals::setSignalHandler( const Signal& signal ) { if ( Main::instance().taskID() == 0 ) eckit::Log::debug() << "Registering signal handler for signal " << std::setw( 2 ) << int( signal ) << " [" << signal << "]" << std::endl; registered_signals_[signal] = signal; std::signal( signal, signal.handler() ); } Signal::Signal( int signum ) : signum_( signum ), str_( strsignal( signum ) ), signal_handler_( fckit_signal_handler ) {} Signal::Signal() : signum_( 0 ), str_(), signal_handler_( SIG_DFL ) {} Signal::Signal( int signum, signal_handler_t signal_handler ) : signum_( signum ), str_( strsignal( signum ) ), signal_handler_( signal_handler ) {} Main::Main( int argc, char** argv, const char* homeenv ) : eckit::Main( argc, argv, homeenv ) { std::set_terminate( &fckit_terminate ); for ( int j = 0; j < argc; ++j ) { std::string arg( argv[j] ); if ( arg.find( "--displayname=" ) == 0 ) { size_t pos = arg.find( "--displayname=" ) + 14; displayName_ = arg.substr( pos ); } if ( arg == "--displayname" ) { if ( j + 1 < argc ) displayName_ = argv[j + 1]; } } taskID( eckit::mpi::comm( "world" ).rank() ); eckit::LibEcKit::instance().setAbortHandler( [] { eckit::Log::error() << "[" << eckit::mpi::comm().rank() << "] " << "calling MPI_Abort" << std::endl; eckit::mpi::comm().abort(); } ); } void Main::initialise( int argc, char** argv, const char* homeenv ) { eckit::AutoLock lock( local_mutex ); if ( not ready() ) { new Main( argc, argv, homeenv ); } } void Main::finalise() { eckit::Log::flush(); } #define SUCCESS 0 extern "C" { int32 fckit__exception_what( char*& what, size_t& what_size ) { what_size = exception_what.size(); what = new char[what_size + 1]; ::strcpy( what, exception_what.c_str() ); return SUCCESS; } int32 fckit__exception_location() { return bool( exception_location ); } int32 fckit__exception_file( char*& file, size_t& file_size ) { std::string f = exception_location ? exception_location.file() : ""; file_size = f.size(); file = new char[file_size + 1]; ::strcpy( file, f.c_str() ); return SUCCESS; } int32 fckit__exception_function( char*& function, size_t& function_size ) { std::string f = exception_location ? exception_location.func() : ""; function_size = f.size(); function = new char[function_size + 1]; ::strcpy( function, f.c_str() ); return SUCCESS; } int32 fckit__exception_line() { return exception_location ? exception_location.line() : 0; } int32 fckit__exception_callstack( char*& callstack, size_t& callstack_size ) { std::string f = exception_callstack; callstack_size = f.size(); callstack = new char[callstack_size + 1]; std::strcpy( callstack, f.c_str() ); return SUCCESS; } } } // namespace fckit fckit-0.14.3/src/fckit/fctest.h0000664000175000017500000000457215202607540016424 0ustar alastairalastair#if 0 (C) Copyright 2013 ECMWF. 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. #endif #if 0 // clang-format off #endif #ifndef FCTEST_H #define FCTEST_H #include "fckit/fckit.h" ! TESTSUITE macro: defines a new testsuite ! To be closed with the END_TESTSUITE macro #define TESTSUITE( TESTSUITE_NAME ) \ module TESTSUITE_NAME;\ use fctest;\ contains; ! TESTSUITE_WITH_FIXTURE macro: defines a new testsuite ! with a given module as fixture. This fixture can ! be used to import required functionality to test ! To be closed with the END_TESTSUITE macro #define TESTSUITE_WITH_FIXTURE( TESTSUITE_NAME, TESTSUITE_FIXTURE ) \ module TESTSUITE_NAME;\ use fctest;\ use TESTSUITE_FIXTURE;\ contains ! END_TESTSUITE macro: closes a TESTSUITE_ #define END_TESTSUITE end module ! TEST macro: define a new test within a TESTSUITE_ #define TEST( TEST_NAME ) subroutine TEST_NAME; ! END_TEST macro: closes a TEST_ #define END_TEST end subroutine; ! TESTSUITE_INIT macro: define a function to be called before any other test #define TESTSUITE_INIT subroutine testsuite_init ! END_TESTSUITE_INIT macro: closes the TESTSUITE_INIT_ function #define END_TESTSUITE_INIT end subroutine testsuite_init ! TESTSUITE_FINALIZE macro: define a function to be called after any other test #define TESTSUITE_FINALISE subroutine testsuite_finalize #define TESTSUITE_FINALIZE subroutine testsuite_finalize ! END_TESTSUITE_FINALIZE macro: closes the TESTSUITE_FINALIZE_ function #define END_TESTSUITE_FINALIZE end subroutine testsuite_finalize ! CHECK macro: check if an expression is true, otherwise fail the test #define CHECK( EXPR ) if(.not.(EXPR)) call ERR(__LINE__) #define FCTEST_CHECK CHECK ! CHECK_EQUAL macro: check if 2 values are exactly equal #define CHECK_EQUAL(V1,V2) call FCE(V1,V2,__LINE__) #define FCTEST_CHECK_EQUAL CHECK_EQUAL ! CHECK_EQUAL macro: check if 2 REAL values are equal with a given tolerance #define CHECK_CLOSE(V1,V2,TOL) call FCC(V1,V2,TOL,__LINE__) #define FCTEST_CHECK_CLOSE CHECK_CLOSE ! FCTEST_ERROR macro: show error #define FCTEST_ERROR() call ERR(__LINE__) #if 0 // clang-format on #endif #endif fckit-0.14.3/src/fckit/Main.h0000664000175000017500000000405415202607540016013 0ustar alastairalastair/* * (C) Copyright 2013 ECMWF. * * 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. */ #pragma once #include #include #include #include #include "eckit/runtime/Main.h" namespace fckit { class Main : public eckit::Main { public: Main( int argc, char** argv, const char* homeenv = 0 ); static void initialise( int argc, char** argv, const char* homeenv = 0 ); static void initialize( int argc, char** argv, const char* homeenv = 0 ) { initialise( argc, argv, homeenv ); } static void finalise(); static void finalize() { finalise(); } }; // ------------------------------------------------------------------------------------ typedef void ( *signal_handler_t )( std::int32_t ); class Signal { public: Signal(); Signal( int signum ); Signal( int signum, signal_handler_t signal_handler ); operator int() const { return signum_; } std::string str() const { return str_; } const signal_handler_t& handler() const { return signal_handler_; } private: friend std::ostream& operator<<( std::ostream&, const Signal& ); int signum_; std::string str_; signal_handler_t signal_handler_; }; // ------------------------------------------------------------------------------------ class Signals { private: Signals() {} public: static Signals& instance(); void setSignalHandlers(); void setSignalHandler( const Signal& ); void restoreSignalHandler( int signum ); void restoreAllSignalHandlers(); const Signal& signal( int signum ) const; private: typedef std::map registered_signals_t; registered_signals_t registered_signals_; }; // ------------------------------------------------------------------------------------ } // namespace fckit fckit-0.14.3/src/fckit/fckit.h.in0000664000175000017500000000556715202607540016646 0ustar alastairalastair#if 0 (C) Copyright 2013 ECMWF. 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. #endif #if 0 // clang-format off #endif #ifndef FCKIT_H #define FCKIT_H #define FCKIT_GIT_SHA1 "@fckit_GIT_SHA1@" #define FCKIT_VERSION "@fckit_VERSION@" #define FCKIT_HAVE_ECKIT @fckit_HAVE_ECKIT@ #define FCKIT_HAVE_ECKIT_MPI_PARALLEL @fckit_HAVE_ECKIT_MPI_PARALLEL@ #define FCKIT_HAVE_FINAL @fckit_HAVE_FINAL@ #define FCKIT_FINAL_FUNCTION_RESULT @FCKIT_FINAL_FUNCTION_RESULT@ #define FCKIT_FINAL_UNINITIALIZED_LOCAL @FCKIT_FINAL_UNINITIALIZED_LOCAL@ #define FCKIT_FINAL_UNINITIALIZED_INTENT_OUT @FCKIT_FINAL_UNINITIALIZED_INTENT_OUT@ #define FCKIT_FINAL_UNINITIALIZED_INTENT_INOUT @FCKIT_FINAL_UNINITIALIZED_INTENT_INOUT@ #define FCKIT_FINAL_NOT_PROPAGATING @FCKIT_FINAL_NOT_PROPAGATING@ #define FCKIT_FINAL_NOT_INHERITING @FCKIT_FINAL_NOT_INHERITING@ #define FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY @FCKIT_FINAL_BROKEN_FOR_ALLOCATABLE_ARRAY@ #define FCKIT_FINAL_BROKEN_FOR_AUTOMATIC_ARRAY @FCKIT_FINAL_BROKEN_FOR_AUTOMATIC_ARRAY@ #define FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY @FCKIT_FINAL_NOT_INHERITING_FOR_ALLOCATABLE_ARRAY@ #define FCKIT_FINAL_NOT_INHERITING_FOR_AUTOMATIC_ARRAY @FCKIT_FINAL_NOT_INHERITING_FOR_AUTOMATIC_ARRAY@ #define FCKIT_HAVE_ECKIT_TENSOR @FCKIT_HAVE_ECKIT_TENSOR@ #define FCKIT_FINAL impure elemental #define FCKIT_FINAL_DEBUGGING 0 #define FCKIT_SUPPRESS_UNUSED( X ) \ associate( unused_ => X ); \ end associate #define PGIBUG_ATLAS_197 @PGIBUG_ATLAS_197@ #if 0 Following is to workaround PGI bug which prevents the use of function c_ptr() PGI bug present from version 17.10, fixed since version 19.4 #endif #if PGIBUG_ATLAS_197 #define CPTR_PGIBUG_A cpp_object_ptr #define CPTR_PGIBUG_B shared_object_%cpp_object_ptr #else #define CPTR_PGIBUG_A c_ptr() #define CPTR_PGIBUG_B c_ptr() #endif #define PGIBUG_ATLAS_197_DEBUG 0 #if 0 When above PGIBUG_ATLAS_197_DEBUG==1 then the c_ptr() member functions are disabled from compilation, to detect possible dangerous use cases when the PGI bug ATLAS-197 is present. #endif #define XLBUG_FCKIT_14 1 #if 0 Following is to workaround XL bug where allocate( character(len=xxx,kind=c_char ) :: string ) does not compile #endif #if XLBUG_FCKIT_14 #define FCKIT_ALLOCATE_CHARACTER( VARIABLE, SIZE ) allocate( character(len=(SIZE)) :: VARIABLE ) #else #define FCKIT_ALLOCATE_CHARACTER( VARIABLE, SIZE ) allocate( character(len=(SIZE),kind=c_char) :: VARIABLE ) #endif #if 0 // clang-format on #endif #endif fckit-0.14.3/src/fckit/Log.h0000664000175000017500000000264115202607540015650 0ustar alastairalastair/* * (C) Copyright 2013 ECMWF. * * 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. */ #pragma once #include "eckit/log/Log.h" namespace fckit { class Log : public eckit::Log { public: enum Style { SIMPLE = 0, PREFIX = 1, TIMESTAMP = 2 }; static void addFortranUnit( int unit, Style = PREFIX, const char* prefix = "" ); static void setFortranUnit( int unit, Style = PREFIX, const char* prefix = "" ); static void addFile( const std::string& path, Style = PREFIX, const std::string& prefix = "" ); static void setFile( const std::string& path, Style = PREFIX, const std::string& prefix = "" ); static void addFile( const char* path, Style = PREFIX, const char* prefix = "" ); static void setFile( const char* path, Style = PREFIX, const char* prefix = "" ); static void addStdOut( Style = PREFIX, const char* prefix = "" ); static void setStdOut( Style = PREFIX, const char* prefix = "" ); static void reset(); static void flush(); // Fortran unit numbers static int output_unit(); static int error_unit(); }; } // namespace fckit fckit-0.14.3/src/fckit/module/0000775000175000017500000000000015202607540016240 5ustar alastairalastairfckit-0.14.3/src/fckit/module/fckit_shared_object.F900000664000175000017500000001063115202607540022475 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fckit.h" module fckit_shared_object_module use fckit_object_module, only : fckit_object use fckit_c_interop_module, only : fckit_c_deleter, fckit_c_nodeleter #if FCKIT_HAVE_ECKIT use fckit_shared_ptr_module, only : fckit_shared_ptr, fckit_refcount_interface, & & fckit_owned #else use fckit_shared_ptr_module, only : fckit_shared_ptr, fckit_refcount_interface #endif implicit none private !======================================================================== ! Public interface public :: fckit_shared_object public :: fckit_c_deleter public :: fckit_c_nodeleter #if FCKIT_HAVE_ECKIT public :: fckit_owned #endif !======================================================================== type, extends(fckit_shared_ptr) :: fckit_shared_object #ifdef _CRAYFTN ! Cray compiler cce/14 has problem with typebound procedure if it is using 'class' type(fckit_object), pointer, public :: shared_object_ => null() #else class(fckit_object), pointer, public :: shared_object_ => null() #endif contains procedure, public :: shared_ptr_cast procedure, public :: reset_c_ptr #if !PGIBUG_ATLAS_197_DEBUG procedure, public :: c_ptr => fckit_shared_object_c_ptr #endif procedure, private :: fckit_shared_object_c_ptr procedure, public :: is_null ! WARNING: Not strictly necessary, as base class (fckit_shared_ptr) has the ! destructor defined. ! - PGI-17.7 needs this, as it does not call the base class destructor (COMPILER BUG!) ! from derived types ! - Cray-8.5.6 needs this as well as it otherwise does not call constructor from ! from function returns #if FCKIT_FINAL_NOT_INHERITING final :: fckit_shared_object__final_auto #endif procedure, public :: fckit_shared_object__reset_c_ptr => reset_c_ptr procedure, public :: fckit_shared_object__shared_ptr_cast => shared_ptr_cast end type !======================================================================== private :: fckit_object private :: fckit_shared_ptr private :: fckit_refcount_interface !======================================================================== CONTAINS !======================================================================== #if FCKIT_FINAL_NOT_INHERITING FCKIT_FINAL subroutine fckit_shared_object__final_auto(this) type(fckit_shared_object), intent(inout) :: this #if FCKIT_FINAL_DEBUGGING write(0,*) "fckit_shared_object__final_auto" #endif #if FCKIT_FINAL_NOT_PROPAGATING call this%final() #endif FCKIT_SUPPRESS_UNUSED( this ) end subroutine #endif function shared_ptr_cast(this) result(success) class(fckit_shared_object) :: this logical :: success class(*), pointer :: shared_object success = .false. nullify( this%shared_object_ ) shared_object => this%shared_ptr() select type( shared_object ) class is( fckit_object ) this%shared_object_ => shared_object success = .true. return end select end function subroutine reset_c_ptr(this, cptr, deleter, refcount ) use, intrinsic :: iso_c_binding, only : c_ptr, c_funptr implicit none class(fckit_shared_object) :: this type(c_ptr), optional :: cptr type(c_funptr), optional :: deleter type(c_funptr), optional :: refcount allocate( fckit_object::this%shared_object_ ) if( present( cptr ) ) then if( present( deleter) ) then call this%shared_object_%reset_c_ptr( cptr, deleter ) else call this%shared_object_%reset_c_ptr( cptr ) endif else call this%shared_object_%reset_c_ptr() endif if( present(refcount) ) then call this%share( this%shared_object_, refcount ) else call this%share( this%shared_object_ ) endif end subroutine function is_null(this) logical :: is_null class(fckit_shared_object) :: this if( .not. associated(this%shared_object_) ) then is_null = .true. else is_null = this%shared_object_%is_null() endif end function function fckit_shared_object_c_ptr(this) result(cptr) use, intrinsic :: iso_c_binding, only : c_ptr type(c_ptr) :: cptr class(fckit_shared_object) :: this cptr = this%shared_object_%CPTR_PGIBUG_A end function end module fckit-0.14.3/src/fckit/module/fckit_owned_object.F900000664000175000017500000002667115202607540022356 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fckit.h" #if FCKIT_FINAL_DEBUGGING #define FCKIT_WRITE_LOC if (fckit_mpi%rank() == 0 ) write(0,'(A,I0,A)',advance='NO') "fckit_owned_object.F90 @ ",__LINE__,' : ' #define FCKIT_WRITE(unit,format) if (fckit_mpi%rank() == 0 ) write(unit,format) #else #define FCKIT_WRITE_LOC #endif #define FCKIT_WRITE_DEBUG if(.false.)write(0,*) module fckit_owned_object_module use, intrinsic :: iso_c_binding, only: c_ptr, c_funptr, c_null_ptr, c_null_funptr, c_int32_t #if FCKIT_FINAL_DEBUGGING use fckit_c_interop_module, only : c_ptr_to_loc use fckit_mpi_module, only : fckit_mpi #endif implicit none private !======================================================================== ! Public interface public fckit_owned_object !======================================================================== type :: fckit_owned_object !! Abstract base class for objects that wrap a C++ object #if !PGIBUG_ATLAS_197 type(c_ptr), private :: cpp_object_ptr = c_null_ptr #else type(c_ptr), public :: cpp_object_ptr = c_null_ptr #endif type(c_funptr), private :: deleter = c_null_funptr !! Internal C pointer logical, private :: return_value = .false. contains procedure, public :: is_null !! Check if internal C pointer is set #if !PGIBUG_ATLAS_197_DEBUG procedure, public :: c_ptr => fckit_owned_object__c_ptr !! Access to internal C pointer #endif procedure, public :: reset_c_ptr !! Nullify internal C pointer procedure, private :: equal !! Compare two object C pointers procedure, private :: not_equal !! Compare two object C pointers generic, public :: operator(==) => equal !! Compare two objects internal C pointer generic, public :: operator(/=) => not_equal !! Compare two objects internal C pointer ! Following line is to avoid PGI compiler bug procedure, private :: fckit_owned_object__c_ptr procedure, public :: final => fckit_owned_object__final #if FCKIT_HAVE_FINAL final :: fckit_owned_object__final_auto #endif procedure, private :: fckit_owned_object_assignment_operator generic, public :: assignment(=) => fckit_owned_object_assignment_operator procedure, public :: owners procedure, public :: attach procedure, public :: detach procedure, public :: return procedure, public :: assignment_operator_hook procedure, public :: consumed end type !======================================================================== private :: c_ptr private :: c_null_ptr private :: c_funptr private :: c_null_funptr private :: c_int32_t !======================================================================== interface subroutine fckit__delete_Owned(this) bind(c,name="fckit__delete_Owned") use, intrinsic :: iso_c_binding, only: c_ptr type(c_ptr), value :: this end subroutine function fckit__Owned__owners(this) bind(c,name="fckit__Owned__owners") use, intrinsic :: iso_c_binding, only: c_int32_t, c_ptr integer(c_int32_t) :: fckit__Owned__owners type(c_ptr), value :: this end function subroutine fckit__Owned__attach(this) bind(c,name="fckit__Owned__attach") use, intrinsic :: iso_c_binding, only: c_ptr type(c_ptr), value :: this end subroutine subroutine fckit__Owned__detach(this) bind(c,name="fckit__Owned__detach") use, intrinsic :: iso_c_binding, only: c_ptr type(c_ptr), value :: this end subroutine end interface !======================================================================== CONTAINS !======================================================================== FCKIT_FINAL subroutine fckit_owned_object__final_auto(this) #ifdef _CRAYFTN use, intrinsic :: iso_c_binding, only : c_loc, c_null_ptr #endif type(fckit_owned_object), intent(inout) :: this #ifdef _CRAYFTN ! Guard necessary for Cray compiler... ! ... when "this" has already been deallocated, and then ! fckit_owned_object__final_auto is called... if( c_loc(this) == c_null_ptr ) then return endif #endif #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A,I0)') "BEGIN fckit_owned_object__final_auto address: ", & & c_ptr_to_loc(this%cpp_object_ptr) #endif if (.not. this%return_value) then if (.not. this%is_null()) then #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A,I0)') "this%final() address:",c_ptr_to_loc(this%cpp_object_ptr) #endif call this%final() endif else #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A,A)') "Applying return-value-optimisation during assignment_operator, ", & & "this%final not called" #endif endif #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A,I0)') "END fckit_owned_object__final_auto address:", & &c_ptr_to_loc(this%cpp_object_ptr) #endif end subroutine subroutine fckit_owned_object__delete( this ) use, intrinsic :: iso_c_binding, only: c_ptr, c_funptr, c_f_procpointer, c_associated, c_null_ptr use fckit_c_interop_module, only : fckit_c_deleter_interface class(fckit_owned_object), intent(inout) :: this procedure(fckit_c_deleter_interface), pointer :: deleter #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A)') "fckit_owned_object__delete" #endif if( c_associated( this%cpp_object_ptr ) ) then if( c_associated( this%deleter ) ) then call c_f_procpointer( this%deleter, deleter ) call deleter( this%cpp_object_ptr ) this%cpp_object_ptr = c_null_ptr endif endif this%cpp_object_ptr = c_null_ptr end subroutine subroutine fckit_owned_object__final(this) class(fckit_owned_object), intent(inout) :: this #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A,I0)') "fckit_owned_object__final address BEGIN: ", c_ptr_to_loc(this%cpp_object_ptr) #endif if( this%is_null() ) then #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A,I0)') "fckit_owned_object__final (uninitialised --> no-op), address: ", & & c_ptr_to_loc(this%cpp_object_ptr) #endif return endif #if FCKIT_FINAL_DEBUGGING if( this%return_value ) then FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A,I0,A,I0,A)') "fckit_owned_object__final on return value, owners = ", & & this%owners(), " address: ", & & loc(this%cpp_object_ptr), " Not applying final() due to return-value-optimisation" return endif #endif if( this%owners() > 0 ) then #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A,I0,A,I0)') "fckit_owned_object__final , owners = ", this%owners(), & & " address: ", c_ptr_to_loc(this%cpp_object_ptr) #endif call this%detach() if( this%owners() == 0 ) then call fckit_owned_object__delete(this) endif endif #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A,I0,A,I0)') "fckit_owned_object__final , owners = ", this%owners(), " address: ", & & c_ptr_to_loc(this%cpp_object_ptr) #endif call this%reset_c_ptr() end subroutine subroutine fckit_owned_object_assignment_operator(this,other) class(fckit_owned_object), intent(inout) :: this class(fckit_owned_object), intent(in) :: other if( other%is_null() ) then write(0,*) "ERROR! other was not initialised" endif if( this /= other ) then #if FCKIT_FINAL_DEBUGGING if( this%is_null() ) then FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A)') "fckit_owned_object_assignment_operator of uninitialised BEGIN" else FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A)') "fckit_owned_object_assignment_operator of initialised BEGIN" endif #endif call this%final() if( other%return_value ) then #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A)') " rhs is a return value" #endif endif call this%reset_c_ptr( other%cpp_object_ptr, other%deleter ) #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A,I0)') " \-> owners ", this%owners() #endif else #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A)') "fckit_owned_object_assignment_operator ( obj_out = obj_in )" #endif endif call this%assignment_operator_hook(other) end subroutine subroutine attach(this) class(fckit_owned_object), intent(inout) :: this if( .not. this%is_null() ) then call fckit__Owned__attach(this%cpp_object_ptr) #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A)') "attach" #endif endif end subroutine subroutine detach(this) class(fckit_owned_object), intent(inout) :: this if( .not. this%is_null() ) then call fckit__Owned__detach(this%cpp_object_ptr) #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A)') "detach" #endif endif end subroutine function owners(this) integer(c_int32_t) :: owners class(fckit_owned_object), intent(in) :: this if( this%is_null() ) then owners = 0 else owners = fckit__Owned__owners(this%cpp_object_ptr) endif end function subroutine return(this) class(fckit_owned_object), intent(inout) :: this this%return_value = .true. #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A)') "return" #endif call this%detach() end subroutine subroutine assignment_operator_hook(this, other) class(fckit_owned_object) :: this class(fckit_owned_object) :: other FCKIT_SUPPRESS_UNUSED( this ) FCKIT_SUPPRESS_UNUSED( other ) end subroutine subroutine consumed(this) class(fckit_owned_object), intent(in) :: this type(fckit_owned_object) :: consumed_object consumed_object = this call consumed_object%final() end subroutine function fckit_owned_object__c_ptr(this) use, intrinsic :: iso_c_binding, only: c_ptr type(c_ptr) :: fckit_owned_object__c_ptr class(fckit_owned_object), intent(in) :: this fckit_owned_object__c_ptr = this%cpp_object_ptr end function function is_null(this) use, intrinsic :: iso_c_binding, only: c_associated logical :: is_null class(fckit_owned_object) :: this if( c_associated( this%cpp_object_ptr ) ) then is_null = .False. else is_null = .True. endif end function logical function equal(obj1,obj2) use fckit_c_interop_module, only : c_ptr_compare_equal class(fckit_owned_object), intent(in) :: obj1 class(fckit_owned_object), intent(in) :: obj2 equal = c_ptr_compare_equal(obj1%cpp_object_ptr,obj2%cpp_object_ptr) end function logical function not_equal(obj1,obj2) use fckit_c_interop_module, only : c_ptr_compare_equal class(fckit_owned_object), intent(in) :: obj1 class(fckit_owned_object), intent(in) :: obj2 if( c_ptr_compare_equal(obj1%cpp_object_ptr,obj2%cpp_object_ptr) ) then not_equal = .False. else not_equal = .True. endif end function subroutine reset_c_ptr(this,cptr,deleter) use, intrinsic :: iso_c_binding, only: c_ptr, c_funptr, c_null_funptr use fckit_c_interop_module class(fckit_owned_object) :: this type(c_ptr), optional :: cptr type(c_funptr), optional :: deleter if( present(cptr) ) then this%cpp_object_ptr = cptr #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A)') "reset_c_ptr -> attach" #endif call this%attach() if( present(deleter) ) then this%deleter = deleter else this%deleter = fckit_c_deleter(fckit__delete_Owned) endif else this%cpp_object_ptr = c_null_ptr this%deleter = c_null_funptr endif #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A)') "reset_c_ptr .. done" #endif end subroutine end module fckit-0.14.3/src/fckit/module/fckit_buffer.cc0000664000175000017500000000153715202607540021206 0ustar alastairalastair/* * (C) Copyright 2013 ECMWF. * * 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. */ #include #include #include #include "eckit/io/SharedBuffer.h" using int32 = std::int32_t; using size_t = std::size_t; extern "C" { int32 c_fckit_buffer_str( const eckit::Buffer* This, char*& str, size_t& size ) { std::string s( *This, This->size() ); size = s.size() + 1; str = new char[size]; strcpy( str, s.c_str() ); return true; } void c_fckit_buffer_delete( eckit::CountedBuffer* This ) { delete This; } } fckit-0.14.3/src/fckit/module/fckit_configuration.inc0000664000175000017500000006152115202607540022767 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #ifndef FORD interface !------------------------------------------------------------------------------- ! void c_fckit_throw_configuration_not_found (const char* name) !------------------------------------------------------------------------------- subroutine c_fckit_throw_configuration_not_found( name ) bind(C,name="c_fckit_t& &hrow_configuration_not_found") use iso_c_binding, only: c_char character(c_char), dimension(*) :: name end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! Configuration* c_fckit_configuration_new () !------------------------------------------------------------------------------- function c_fckit_configuration_new() bind(C,name="c_fckit_configuration_new") use iso_c_binding, only: c_ptr type(c_ptr) :: c_fckit_configuration_new end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! Configuration* c_fckit_configuration_new_from_yaml (const char* yaml) !------------------------------------------------------------------------------- function c_fckit_configuration_new_from_yaml( yaml ) bind(C,name="c_fckit_confi& &guration_new_from_yaml") use iso_c_binding, only: c_ptr, c_char type(c_ptr) :: c_fckit_configuration_new_from_yaml character(c_char), dimension(*) :: yaml end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! Configuration* c_fckit_configuration_new_from_file (const char* path) !------------------------------------------------------------------------------- function c_fckit_configuration_new_from_file( path ) bind(C,name="c_fckit_confi& &guration_new_from_file") use iso_c_binding, only: c_ptr, c_char type(c_ptr) :: c_fckit_configuration_new_from_file character(c_char), dimension(*) :: path end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! Configuration* c_fckit_configuration_new_from_buffer (eckit::Buffer* buffer) !------------------------------------------------------------------------------- function c_fckit_configuration_new_from_buffer( buffer ) bind(C,name="c_fckit_c& &onfiguration_new_from_buffer") use iso_c_binding, only: c_ptr type(c_ptr) :: c_fckit_configuration_new_from_buffer type(c_ptr), value :: buffer end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_delete (Configuration* This) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_delete( This ) bind(C,name="c_fckit_configurat& &ion_delete") use iso_c_binding, only: c_ptr type(c_ptr), value :: This end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_config (Configuration* This, const char* name, ! const Configuration* value) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_config( This, name, value ) bind(C,name="c& &_fckit_configuration_set_config") use iso_c_binding, only: c_ptr, c_char type(c_ptr), value :: This character(c_char), dimension(*) :: name type(c_ptr), value :: value end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_config_list (Configuration* This, const char* n ! ame, const Configuration* value[], size_t size) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_config_list( This, name, value, size ) bin& &d(C,name="c_fckit_configuration_set_config_list") use iso_c_binding, only: c_int32_t, c_size_t, c_ptr, c_char type(c_ptr), value :: This character(c_char), dimension(*) :: name type(c_ptr), value :: value integer(c_size_t), value :: size end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_bool (Configuration* This, const char* name, ! int32 value) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_bool( This, name, value ) bind(C,name="c_& &fckit_configuration_set_bool") use iso_c_binding, only: c_int32_t, c_ptr, c_char type(c_ptr), value :: This character(c_char), dimension(*) :: name integer(c_int32_t), value :: value end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_int32 (Configuration* This, const char* name, ! int32 value) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_int32( This, name, value ) bind(C,name="c_& &fckit_configuration_set_int32") use iso_c_binding, only: c_int32_t, c_ptr, c_char type(c_ptr), value :: This character(c_char), dimension(*) :: name integer(c_int32_t), value :: value end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_int64 (Configuration* This, const char* name, ! int64 value) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_int64( This, name, value ) bind(C,name="c_& &fckit_configuration_set_int64") use iso_c_binding, only: c_ptr, c_int64_t, c_char type(c_ptr), value :: This character(c_char), dimension(*) :: name integer(c_int64_t), value :: value end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_float (Configuration* This, const char* name, f ! loat value) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_float( This, name, value ) bind(C,name="c_& &fckit_configuration_set_float") use iso_c_binding, only: c_ptr, c_char, c_float type(c_ptr), value :: This character(c_char), dimension(*) :: name real(c_float), value :: value end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_double (Configuration* This, const char* name, ! double value) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_double( This, name, value ) bind(C,name="c& &_fckit_configuration_set_double") use iso_c_binding, only: c_ptr, c_char, c_double type(c_ptr), value :: This character(c_char), dimension(*) :: name real(c_double), value :: value end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_string (Configuration* This, const char* name, ! const char* value) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_string( This, name, value ) bind(C,name="c& &_fckit_configuration_set_string") use iso_c_binding, only: c_ptr, c_char type(c_ptr), value :: This character(c_char), dimension(*) :: name character(c_char), dimension(*) :: value end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_array_string (Configuration* This, const char* n ! ame, const char* value, size_t size) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_array_string( This, name, value, length, size ) bin& &d(C,name="c_fckit_configuration_set_array_string") use iso_c_binding, only: c_int32_t, c_size_t, c_ptr, c_char type(c_ptr), value :: This character(c_char), dimension(*) :: name character(c_char), dimension(*) :: value integer(c_size_t), value :: length integer(c_size_t), value :: size end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_array_int32 (Configuration* This, const char* n ! ame, int32 value[], size_t size) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_array_int32( This, name, value, size ) bin& &d(C,name="c_fckit_configuration_set_array_int32") use iso_c_binding, only: c_int32_t, c_size_t, c_ptr, c_char type(c_ptr), value :: This character(c_char), dimension(*) :: name integer(c_int32_t), dimension(*) :: value integer(c_size_t), value :: size end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_array_int64 (Configuration* This, const char* n ! ame, int64 value[], size_t size) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_array_int64( This, name, value, size ) bin& &d(C,name="c_fckit_configuration_set_array_int64") use iso_c_binding, only: c_size_t, c_ptr, c_int64_t, c_char type(c_ptr), value :: This character(c_char), dimension(*) :: name integer(c_int64_t), dimension(*) :: value integer(c_size_t), value :: size end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_array_float (Configuration* This, const char* n ! ame, float value[], size_t size) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_array_float( This, name, value, size ) bin& &d(C,name="c_fckit_configuration_set_array_float") use iso_c_binding, only: c_size_t, c_ptr, c_char, c_float type(c_ptr), value :: This character(c_char), dimension(*) :: name real(c_float), dimension(*) :: value integer(c_size_t), value :: size end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_set_array_double (Configuration* This, const char* ! name, double value[], size_t size) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_set_array_double( This, name, value, size ) bi& &nd(C,name="c_fckit_configuration_set_array_double") use iso_c_binding, only: c_size_t, c_ptr, c_char, c_double type(c_ptr), value :: This character(c_char), dimension(*) :: name real(c_double), dimension(*) :: value integer(c_size_t), value :: size end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_config (const Configuration* This, const char* ! name, LocalConfiguration* value) !------------------------------------------------------------------------------- function c_fckit_configuration_get_config( This, name, value ) bind(C,name="c_f& &ckit_configuration_get_config") use iso_c_binding, only: c_char, c_ptr, c_int32_t integer(c_int32_t) :: c_fckit_configuration_get_config type(c_ptr), value :: This character(c_char), dimension(*) :: name type(c_ptr), value :: value end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_config_list (const Configuration* This, const ! char* name, LocalConfiguration** &value, size_t &size) !------------------------------------------------------------------------------- function c_fckit_configuration_get_config_list( This, name, value, size ) bind(& &C,name="c_fckit_configuration_get_config_list") use iso_c_binding, only: c_char, c_ptr, c_int32_t, c_size_t integer(c_int32_t) :: c_fckit_configuration_get_config_list type(c_ptr), value :: This character(c_char), dimension(*) :: name type(c_ptr) :: value integer(c_size_t) :: size end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_bool (const Configuration* This, const char* ! name, int32& value) !------------------------------------------------------------------------------- function c_fckit_configuration_get_bool( This, name, value ) bind(C,name="c_fc& &kit_configuration_get_bool") use iso_c_binding, only: c_char, c_ptr, c_int32_t integer(c_int32_t) :: c_fckit_configuration_get_bool type(c_ptr), value :: This character(c_char), dimension(*) :: name integer(c_int32_t) :: value end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_int32 (const Configuration* This, const char* ! name, int32& value) !------------------------------------------------------------------------------- function c_fckit_configuration_get_int32( This, name, value ) bind(C,name="c_fc& &kit_configuration_get_int32") use iso_c_binding, only: c_char, c_ptr, c_int32_t integer(c_int32_t) :: c_fckit_configuration_get_int32 type(c_ptr), value :: This character(c_char), dimension(*) :: name integer(c_int32_t) :: value end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_int64 (const Configuration* This, const char* ! name, int64& value) !------------------------------------------------------------------------------- function c_fckit_configuration_get_int64( This, name, value ) bind(C,name="c_fc& &kit_configuration_get_int64") use iso_c_binding, only: c_char, c_ptr, c_int64_t, c_int32_t integer(c_int32_t) :: c_fckit_configuration_get_int64 type(c_ptr), value :: This character(c_char), dimension(*) :: name integer(c_int64_t) :: value end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_float (const Configuration* This, const char* ! name, float& value) !------------------------------------------------------------------------------- function c_fckit_configuration_get_float( This, name, value ) bind(C,name="c_fc& &kit_configuration_get_float") use iso_c_binding, only: c_char, c_ptr, c_int32_t, c_float integer(c_int32_t) :: c_fckit_configuration_get_float type(c_ptr), value :: This character(c_char), dimension(*) :: name real(c_float) :: value end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_double (const Configuration* This, const char* ! name, double& value) !------------------------------------------------------------------------------- function c_fckit_configuration_get_double( This, name, value ) bind(C,name="c_f& &ckit_configuration_get_double") use iso_c_binding, only: c_char, c_ptr, c_int32_t, c_double integer(c_int32_t) :: c_fckit_configuration_get_double type(c_ptr), value :: This character(c_char), dimension(*) :: name real(c_double) :: value end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_string( const Configuration* This, const char* ! name, char* &value, size_t &size) !------------------------------------------------------------------------------- function c_fckit_configuration_get_string( This, name, value, size ) bind(C,nam& &e="c_fckit_configuration_get_string") use iso_c_binding, only: c_char, c_ptr, c_int32_t, c_size_t integer(c_int32_t) :: c_fckit_configuration_get_string type(c_ptr), value :: This character(c_char), dimension(*) :: name type(c_ptr) :: value integer(c_size_t) :: size end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_array_int32 (const Configuration* This, const ! char* name, int32* &value, size_t& size) !------------------------------------------------------------------------------- function c_fckit_configuration_get_array_int32( This, name, value, size ) bind(& &C,name="c_fckit_configuration_get_array_int32") use iso_c_binding, only: c_char, c_ptr, c_int32_t, c_size_t integer(c_int32_t) :: c_fckit_configuration_get_array_int32 type(c_ptr), value :: This character(c_char), dimension(*) :: name type(c_ptr) :: value integer(c_size_t) :: size end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int64 c_fckit_configuration_get_array_int64 (const Configuration* This, const ! char* name, int64* &value, size_t& size) !------------------------------------------------------------------------------- function c_fckit_configuration_get_array_int64( This, name, value, size ) bind(C& &,name="c_fckit_configuration_get_array_int64") use iso_c_binding, only: c_char, c_ptr, c_int32_t, c_size_t integer(c_int32_t) :: c_fckit_configuration_get_array_int64 type(c_ptr), value :: This character(c_char), dimension(*) :: name type(c_ptr) :: value integer(c_size_t) :: size end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_array_float (const Configuration* This, const ch ! ar* name, float* &value, size_t& size) !------------------------------------------------------------------------------- function c_fckit_configuration_get_array_float( This, name, value, size ) bind(& &C,name="c_fckit_configuration_get_array_float") use iso_c_binding, only: c_char, c_ptr, c_int32_t, c_size_t integer(c_int32_t) :: c_fckit_configuration_get_array_float type(c_ptr), value :: This character(c_char), dimension(*) :: name type(c_ptr) :: value integer(c_size_t) :: size end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_array_double (const Configuration* This, const ! char* name, double* &value, size_t& size) !------------------------------------------------------------------------------- function c_fckit_configuration_get_array_double( This, name, value, size ) bind& &(C,name="c_fckit_configuration_get_array_double") use iso_c_binding, only: c_char, c_ptr, c_int32_t, c_size_t integer(c_int32_t) :: c_fckit_configuration_get_array_double type(c_ptr), value :: This character(c_char), dimension(*) :: name type(c_ptr) :: value integer(c_size_t) :: size end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_array_string (const Configuration* This, const c ! har* name, char* &value, size_t& size, size_t* &offsets, size_t& numelem) !------------------------------------------------------------------------------- function c_fckit_configuration_get_array_string( This, name, value, size, offsets, numelem) bind& &(C,name="c_fckit_configuration_get_array_string") use iso_c_binding, only: c_char, c_ptr, c_int32_t, c_size_t integer(c_int32_t) :: c_fckit_configuration_get_array_string type(c_ptr), value :: This character(c_char), dimension(*) :: name type(c_ptr) :: value integer(c_size_t) :: size type(c_ptr) :: offsets integer(c_size_t) :: numelem end function !---------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_size (const Configuration* This) !------------------------------------------------------------------------------- function c_fckit_configuration_size( This ) bind(C,name="c_fckit_configura& &tion_size") use iso_c_binding, only: c_ptr, c_int32_t integer(c_int32_t) :: c_fckit_configuration_size type(c_ptr), value :: This end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_has (const Configuration* This, const char *name) !------------------------------------------------------------------------------- function c_fckit_configuration_has( This, name ) bind(C,name="c_fckit_configura& &tion_has") use iso_c_binding, only: c_char, c_ptr, c_int32_t integer(c_int32_t) :: c_fckit_configuration_has type(c_ptr), value :: This character(c_char), dimension(*) :: name end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_key( const Configuration* This, int32 index, char*& value, size_t& size ) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_key( This, index, value, size ) bind(C,nam& &e="c_fckit_configuration_key") use iso_c_binding, only: c_char, c_ptr, c_int32_t, c_size_t type(c_ptr), value :: This integer(c_int32_t), value :: index type(c_ptr) :: value integer(c_size_t) :: size end subroutine !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! int32 c_fckit_configuration_get_size (const Configuration* This, const char *name) !------------------------------------------------------------------------------- function c_fckit_configuration_get_size( This, name ) bind(C,name="c_fckit_configura& &tion_get_size") use iso_c_binding, only: c_char, c_ptr, c_int32_t integer(c_int32_t) :: c_fckit_configuration_get_size type(c_ptr), value :: This character(c_char), dimension(*) :: name end function !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! void c_fckit_configuration_json(const Configuration* This, char* &json, int &s ! ize) !------------------------------------------------------------------------------- subroutine c_fckit_configuration_json( This, json, size ) bind(C,name="c_fckit_& &configuration_json") use iso_c_binding, only: c_ptr, c_size_t type(c_ptr), value :: This type(c_ptr) :: json integer(c_size_t) :: size end subroutine !------------------------------------------------------------------------------- end interface #endif fckit-0.14.3/src/fckit/module/fckit_shared_ptr.F900000664000175000017500000002273615202607540022045 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fckit.h" #if FCKIT_FINAL_DEBUGGING #define FCKIT_WRITE_LOC write(0,'(A,I0,A)',advance='NO') "fckit_shared_ptr.F90 @ ",__LINE__,' : ' #define FCKIT_WRITE(unit,format) write(unit,format) #endif module fckit_shared_ptr_module #if FCKIT_HAVE_ECKIT use fckit_refcount_module, only : & & fckit_refcount, & & fckit_refcount_interface, & & fckit_external, & & fckit_owned #else use fckit_refcount_module, only : & & fckit_refcount, & & fckit_refcount_interface, & & fckit_external #endif implicit none private !======================================================================== ! Public interface public fckit_shared_ptr public fckit_make_shared public fckit_refcount public fckit_refcount_interface public fckit_external #if FCKIT_HAVE_ECKIT public fckit_owned #endif !======================================================================== type :: fckit_shared_ptr class(*), pointer, private :: shared_ptr_ ! => null() class(fckit_refcount), pointer , private :: refcount_ => null() logical, private :: is_null_ = .true. ! Compiler bug for gcc > 7 : we may not default assign shared_ptr_ to null() ! Instead we use this `is_null` variable (See JIRA issue FCKIT-21) logical, private :: return_value = .false. ! This variable should not be necessary, ! but seems to overcome compiler issues ( gfortran 5.3, 6.3 ) contains procedure, public :: final => fckit_shared_ptr__final procedure, public :: fckit_shared_ptr__final #if FCKIT_HAVE_FINAL final :: fckit_shared_ptr__final_auto #endif procedure, private :: clear_shared_ptr procedure, public :: reset_shared_ptr generic, public :: reset => clear_shared_ptr, reset_shared_ptr generic, public :: assignment(=) => reset_shared_ptr procedure, public :: owners procedure, public :: attach procedure, public :: detach procedure, public :: return procedure, public :: shared_ptr => get_shared_ptr procedure, public :: shared_ptr_cast procedure, public :: clear procedure, public :: share procedure, public :: consumed end type !======================================================================== CONTAINS !======================================================================== subroutine deallocate_shared_ptr( shared_ptr ) use fckit_final_module, only: fckit_final class(*), pointer :: shared_ptr #ifndef __ibmxl__ deallocate(shared_ptr) #else ! FCKIT-17: Runtime error when deallocating unlimited polymorphic pointer ! MEMORY LEAK!!! ! IBM XL COMPILER AT RUNTIME GIVES ERROR: ! 1525-109 Error encountered while attempting to deallocate a data object. ! The program will stop. #endif nullify( shared_ptr ) end subroutine subroutine fckit_finalise( shared_ptr ) use fckit_final_module, only: fckit_final use fckit_object_module, only: fckit_object class(*), pointer :: shared_ptr select type( shared_ptr) #ifdef _CRAYFTN ! Cray compiler cce/14 has problem with typebound procedure if it is using 'class' type is(fckit_object) #if FCKIT_FINAL_DEBUGGING write(0,*) "fckit_object%final()" #endif call shared_ptr%final() #endif class is(fckit_final) #if FCKIT_FINAL_DEBUGGING write(0,*) "fckit_final%final()" #endif call shared_ptr%final() end select end subroutine FCKIT_FINAL subroutine fckit_shared_ptr__final_auto(this) #ifdef _CRAYFTN use, intrinsic :: iso_c_binding, only : c_loc, c_null_ptr #endif type(fckit_shared_ptr), intent(inout) :: this #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,*) "fckit_shared_ptr__final_auto" #endif #ifdef _CRAYFTN ! Guard necessary for Cray compiler... ! ... when "this" has already been deallocated, and then ! fckit_shared_ptr__final_auto is called... if( c_loc(this) == c_null_ptr ) then return endif #endif if (.not. this%return_value) then if( .not. this%is_null_ ) then if( this%owners() > 0 ) then call this%final() endif endif else #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE_LOC FCKIT_WRITE(0,'(A)') "Applying return-value-optimisation during assignment_operator, this%final not called" #endif endif end subroutine subroutine fckit_shared_ptr__final(this) class(fckit_shared_ptr), intent(inout) :: this #if FCKIT_FINAL_DEBUGGING write(0,*) "fckit_shared_ptr__final" #endif if( this%is_null_ ) then #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE(0,*) "fckit_shared_ptr__final (uninitialised --> no-op)" #endif call this%clear() return endif #if FCKIT_FINAL_DEBUGGING if( this%return_value ) then FCKIT_WRITE(0,'(A,I0)') " fckit_shared_ptr__final on return value, owners = ", this%owners() endif #endif if( this%owners() >= 0 ) then #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE(0,'(A,I0)') " fckit_shared_ptr__final , owners = ", this%owners() #endif call this%detach() if( this%owners() == 0 ) then #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE(0,*) " + call fckit_finalise(this%shared_ptr_)" #endif call fckit_finalise(this%shared_ptr_) call deallocate_shared_ptr(this%shared_ptr_) deallocate(this%refcount_) endif endif call this%clear() end subroutine subroutine clear_shared_ptr(obj_out) class(fckit_shared_ptr), intent(inout) :: obj_out if( .not. obj_out%is_null_ ) then nullify(obj_out%shared_ptr_) nullify(obj_out%refcount_) obj_out%is_null_ = .true. endif end subroutine subroutine clear(obj_out) class(fckit_shared_ptr), intent(inout) :: obj_out call obj_out%clear_shared_ptr() end subroutine subroutine reset_shared_ptr(obj_out,obj_in) class(fckit_shared_ptr), intent(inout) :: obj_out class(fckit_shared_ptr), intent(in) :: obj_in #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE(0,*) "fckit_shared_ptr::reset_shared_ptr(out,in)" #endif if( obj_in%is_null_ ) then write(0,*) "ERROR! obj_in was not initialised" endif if( obj_out%is_null_ ) then nullify( obj_out%shared_ptr_ ) ! so that we can check association endif if( .not. associated( obj_out%shared_ptr_, obj_in%shared_ptr_ ) ) then #if FCKIT_FINAL_DEBUGGING if( obj_out%is_null_ ) then FCKIT_WRITE(0,'(A)') "reset_shared_ptr of uninitialised" else FCKIT_WRITE(0,'(A)') "reset_shared_ptr of initialised" endif #endif call obj_out%final() obj_out%shared_ptr_ => obj_in%shared_ptr_ obj_out%refcount_ => obj_in%refcount_ obj_out%is_null_ = .not. associated( obj_out%shared_ptr_ ) if( obj_out%shared_ptr_cast() ) then call obj_out%attach() else call obj_out%clear() call bad_cast() endif else #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE(0,*) "reset_shared_ptr ( obj_out = obj_in )" #endif if( obj_out%shared_ptr_cast() ) then ; endif endif end subroutine subroutine attach(this) class(fckit_shared_ptr), intent(inout) :: this if( .not. this%is_null_ ) then call this%refcount_%attach() endif end subroutine subroutine detach(this) class(fckit_shared_ptr), intent(inout) :: this if( .not. this%is_null_ ) then call this%refcount_%detach() endif end subroutine function owners(this) use, intrinsic :: iso_c_binding, only : c_int32_t integer(c_int32_t) :: owners class(fckit_shared_ptr), intent(in) :: this if( .not. this%is_null_ ) then owners = this%refcount_%owners() else owners = 0 endif end function subroutine return(this) !! Transfer ownership to left hand side of "assignment(=)" class(fckit_shared_ptr), intent(inout) :: this this%return_value = .true. call this%detach() end subroutine function get_shared_ptr(this) result(shared_ptr) class(*), pointer :: shared_ptr class(fckit_shared_ptr), intent(in) :: this shared_ptr => this%shared_ptr_ end function function shared_ptr_cast(this) result(success) class(fckit_shared_ptr) :: this logical :: success success = .true. FCKIT_SUPPRESS_UNUSED( this ) end function function fckit_make_shared( ptr ) result(this) type(fckit_shared_ptr) :: this class(*), target :: ptr #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE(0,*) "begin fckit_make_shared" #endif call this%share( ptr ) call this%return() #if FCKIT_FINAL_DEBUGGING write(0,*) " this%owners() = ", this%owners() write(0,*) "end fckit_make_shared" #endif end function subroutine share( this, ptr, refcount ) use, intrinsic :: iso_c_binding, only : c_funptr, c_f_procpointer class(fckit_shared_ptr) :: this class(*), target :: ptr type(c_funptr), optional :: refcount procedure(fckit_refcount_interface), pointer :: opt_refcount if( present(refcount) ) then call c_f_procpointer( refcount, opt_refcount ) else call fckit_external(opt_refcount) endif this%shared_ptr_ => ptr this%is_null_ = .not. associated( this%shared_ptr_ ) call opt_refcount(this%refcount_, this%shared_ptr_) call this%refcount_%attach() #if FCKIT_FINAL_DEBUGGING FCKIT_WRITE(0,*) "share --> attach" #endif end subroutine subroutine bad_cast(message) character(len=*), optional :: message if( present(message) ) then write(0,'("ERROR: bad_cast -- ",A)') message else write(0,'("ERROR: bad cast")') endif end subroutine subroutine consumed(this) class(fckit_shared_ptr), intent(in) :: this type(fckit_shared_ptr) :: consumed_object consumed_object = this call consumed_object%final() end subroutine end module fckit-0.14.3/src/fckit/module/fckit_signal.inc0000664000175000017500000000715215202607540021375 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #ifdef FORD #define FORD_PRIVATE public #else #define FORD_PRIVATE private interface !void fckit__set_signal_handler( int signum, fckit::signal_handler_t ) subroutine fckit__set_signal_handler( signum, signal_handler ) bind(c) use iso_c_binding, only : c_int32_t, c_funptr integer(c_int32_t), value :: signum type(c_funptr), value :: signal_handler end subroutine !void fckit__set_fckit_signal_handler( int signum ) subroutine fckit__set_fckit_signal_handler( signum ) bind(c) use iso_c_binding, only : c_int32_t integer(c_int32_t), value :: signum end subroutine !void fckit__set_fckit_signal_handlers() subroutine fckit__set_fckit_signal_handlers() bind(c) end subroutine !void fckit__raise_signal( int signum ) subroutine fckit__raise_signal( signum ) bind(c) use iso_c_binding, only : c_int32_t integer(c_int32_t), value :: signum end subroutine !void fckit__restore_signal_handler( int signum ) subroutine fckit__restore_signal_handler( signum ) bind(c) use iso_c_binding, only : c_int32_t integer(c_int32_t), value :: signum end subroutine !void fckit__restore_all_signal_handlers() subroutine fckit__restore_all_signal_handlers() bind(c) end subroutine !int fckit__SIGABRT () function fckit__SIGABRT() result(signum) bind(c,name="fckit__SIGABRT") use iso_c_binding, only: c_int32_t integer(c_int32_t) :: signum end function !int fckit__SIGKILL () function fckit__SIGKILL() result(signum) bind(c,name="fckit__SIGKILL") use iso_c_binding, only: c_int32_t integer(c_int32_t) :: signum end function !int fckit__SIGALRM () function fckit__SIGALRM() result(signum) bind(c,name="fckit__SIGALRM") use iso_c_binding, only: c_int32_t integer(c_int32_t) :: signum end function !int fckit__SIGINT () function fckit__SIGINT() result(signum) bind(c,name="fckit__SIGINT") use iso_c_binding, only: c_int32_t integer(c_int32_t) :: signum end function !int fckit__SIGFPE () function fckit__SIGFPE() result(signum) bind(c,name="fckit__SIGFPE") use iso_c_binding, only: c_int32_t integer(c_int32_t) :: signum end function !int fckit__SIGILL () function fckit__SIGILL() result(signum) bind(c,name="fckit__SIGILL") use iso_c_binding, only: c_int32_t integer(c_int32_t) :: signum end function !int fckit__SIGSEGV () function fckit__SIGSEGV() result(signum) bind(c,name="fckit__SIGSEGV") use iso_c_binding, only: c_int32_t integer(c_int32_t) :: signum end function !int fckit__SIGTERM () function fckit__SIGTERM() result(signum) bind(c,name="fckit__SIGTERM") use iso_c_binding, only: c_int32_t integer(c_int32_t) :: signum end function !int fckit__SIGTRAP () function fckit__SIGTRAP() result(signum) bind(c,name="fckit__SIGTRAP") use iso_c_binding, only: c_int32_t integer(c_int32_t) :: signum end function !int fckit__SIGBUS () function fckit__SIGBUS() result(signum) bind(c,name="fckit__SIGBUS") use iso_c_binding, only: c_int32_t integer(c_int32_t) :: signum end function end interface #endif interface subroutine fckit_signal_handler( signum ) bind(C) use, intrinsic :: iso_c_binding, only : c_int32_t integer(c_int32_t), value, intent(in) :: signum end subroutine end interface fckit-0.14.3/src/fckit/module/fckit_log.F900000664000175000017500000003012615202607540020463 0ustar alastairalastair! (C) Copyright 2013 ECMWF. ! ! 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. #include "fckit/fckit.h" module fckit_log_module !! Provides [[fckit_log_module:fckit_log(variable)]] for logging and to configure logging use fckit_object_module, only: fckit_object use, intrinsic :: iso_c_binding, only : c_int32_t implicit none private public :: log ! DEPRECATED, USE fckit_log INSTEAD! public :: fckit_log public :: fckit_logchannel private :: fckit_object private :: c_int32_t #include "fckit_log.inc" type, FORD_PRIVATE :: fckit_log_type !! Private type of [[fckit_log_module:fckit_log(variable)]] module variable !! !! It wraps ```eckit::Log```, allowing Fortran and C++ code to log to the !! same output channels integer(c_int32_t) :: SIMPLE = 0 !! Style for logging without any prefix integer(c_int32_t) :: PREFIX = 1 !! Style for logging with prefix !! !! (I) --> info !! (W) --> warning !! (E) --> error !! (D) --> debug integer(c_int32_t) :: TIMESTAMP = 2 !! Style for logging with prefix that contains time stamp and taskID !! !!